home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / system.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  239.3 KB  |  9,346 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Delphi Runtime Library                          }
  4. {       System Unit                                     }
  5. {                                                       }
  6. {       Copyright (C) 1988,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit System;
  11.  
  12. {$H+,I-,S-}
  13.  
  14. interface
  15.  
  16. const
  17.  
  18. { Variant type codes }
  19.  
  20.   varEmpty    = $0000;
  21.   varNull     = $0001;
  22.   varSmallint = $0002;
  23.   varInteger  = $0003;
  24.   varSingle   = $0004;
  25.   varDouble   = $0005;
  26.   varCurrency = $0006;
  27.   varDate     = $0007;
  28.   varOleStr   = $0008;
  29.   varDispatch = $0009;
  30.   varError    = $000A;
  31.   varBoolean  = $000B;
  32.   varVariant  = $000C;
  33.   varUnknown  = $000D;
  34.   varByte     = $0011;
  35.   varString   = $0100;
  36.   varTypeMask = $0FFF;
  37.   varArray    = $2000;
  38.   varByRef    = $4000;
  39.  
  40. { TVarRec.VType values }
  41.  
  42.   vtInteger    = 0;
  43.   vtBoolean    = 1;
  44.   vtChar       = 2;
  45.   vtExtended   = 3;
  46.   vtString     = 4;
  47.   vtPointer    = 5;
  48.   vtPChar      = 6;
  49.   vtObject     = 7;
  50.   vtClass      = 8;
  51.   vtWideChar   = 9;
  52.   vtPWideChar  = 10;
  53.   vtAnsiString = 11;
  54.   vtCurrency   = 12;
  55.   vtVariant    = 13;
  56.   vtInterface  = 14;
  57.   vtWideString = 15;
  58.  
  59. { Virtual method table entries }
  60.  
  61.   vmtSelfPtr           = -64;
  62.   vmtIntfTable         = -60;
  63.   vmtAutoTable         = -56;
  64.   vmtInitTable         = -52;
  65.   vmtTypeInfo          = -48;
  66.   vmtFieldTable        = -44;
  67.   vmtMethodTable       = -40;
  68.   vmtDynamicTable      = -36;
  69.   vmtClassName         = -32;
  70.   vmtInstanceSize      = -28;
  71.   vmtParent            = -24;
  72.   vmtSafeCallException = -20;
  73.   vmtDefaultHandler    = -16;
  74.   vmtNewInstance       = -12;
  75.   vmtFreeInstance      = -8;
  76.   vmtDestroy           = -4;
  77.  
  78.   vmtQueryInterface    = 0;
  79.   vmtAddRef            = 4;
  80.   vmtRelease           = 8;
  81.   vmtCreateObject      = 12;
  82.  
  83. type
  84.  
  85.   TObject = class;
  86.  
  87.   TClass = class of TObject;
  88.  
  89.   PGUID = ^TGUID;
  90.   TGUID = record
  91.     D1: Integer;
  92.     D2: Word;
  93.     D3: Word;
  94.     D4: array[0..7] of Byte;
  95.   end;
  96.  
  97.   PInterfaceEntry = ^TInterfaceEntry;
  98.   TInterfaceEntry = record
  99.     IID: TGUID;
  100.     VTable: Pointer;
  101.     IOffset: Integer;
  102.   end;
  103.  
  104.   PInterfaceTable = ^TInterfaceTable;
  105.   TInterfaceTable = record
  106.     EntryCount: Integer;
  107.     Entries: array[0..9999] of TInterfaceEntry;
  108.   end;
  109.  
  110.   TObject = class
  111.     constructor Create;
  112.     procedure Free;
  113.     class function InitInstance(Instance: Pointer): TObject;
  114.     procedure CleanupInstance;
  115.     function ClassType: TClass;
  116.     class function ClassName: ShortString;
  117.     class function ClassNameIs(const Name: string): Boolean;
  118.     class function ClassParent: TClass;
  119.     class function ClassInfo: Pointer;
  120.     class function InstanceSize: Longint;
  121.     class function InheritsFrom(AClass: TClass): Boolean;
  122.     procedure Dispatch(var Message);
  123.     class function MethodAddress(const Name: ShortString): Pointer;
  124.     class function MethodName(Address: Pointer): ShortString;
  125.     function FieldAddress(const Name: ShortString): Pointer;
  126.     function GetInterface(const IID: TGUID; out Obj): Boolean;
  127.     class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
  128.     class function GetInterfaceTable: PInterfaceTable;
  129.     function SafeCallException(ExceptObject: TObject;
  130.       ExceptAddr: Pointer): Integer; virtual;
  131.     procedure DefaultHandler(var Message); virtual;
  132.     class function NewInstance: TObject; virtual;
  133.     procedure FreeInstance; virtual;
  134.     destructor Destroy; virtual;
  135.   end;
  136.  
  137.   IUnknown = interface
  138.     ['{00000000-0000-0000-C000-000000000046}']
  139.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  140.     function _AddRef: Integer; stdcall;
  141.     function _Release: Integer; stdcall;
  142.   end;
  143.  
  144.   IDispatch = interface(IUnknown)
  145.     ['{00020400-0000-0000-C000-000000000046}']
  146.     function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
  147.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
  148.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  149.       NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
  150.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  151.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  152.   end;
  153.  
  154.   TInterfacedObject = class(TObject, IUnknown)
  155.   private
  156.     FRefCount: Integer;
  157.   protected
  158.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  159.     function _AddRef: Integer; stdcall;
  160.     function _Release: Integer; stdcall;
  161.   public
  162.     property RefCount: Integer read FRefCount;
  163.   end;
  164.  
  165.   TInterfacedClass = class of TInterfacedObject;
  166.  
  167.   TVarArrayBound = record
  168.     ElementCount: Integer;
  169.     LowBound: Integer;
  170.   end;
  171.  
  172.   PVarArray = ^TVarArray;
  173.   TVarArray = record
  174.     DimCount: Word;
  175.     Flags: Word;
  176.     ElementSize: Integer;
  177.     LockCount: Integer;
  178.     Data: Pointer;
  179.     Bounds: array[0..255] of TVarArrayBound;
  180.   end;
  181.  
  182.   PVarData = ^TVarData;
  183.   TVarData = record
  184.     VType: Word;
  185.     Reserved1, Reserved2, Reserved3: Word;
  186.     case Integer of
  187.       varSmallint: (VSmallint: Smallint);
  188.       varInteger:  (VInteger: Integer);
  189.       varSingle:   (VSingle: Single);
  190.       varDouble:   (VDouble: Double);
  191.       varCurrency: (VCurrency: Currency);
  192.       varDate:     (VDate: Double);
  193.       varOleStr:   (VOleStr: PWideChar);
  194.       varDispatch: (VDispatch: Pointer);
  195.       varError:    (VError: Integer);
  196.       varBoolean:  (VBoolean: WordBool);
  197.       varUnknown:  (VUnknown: Pointer);
  198.       varByte:     (VByte: Byte);
  199.       varString:   (VString: Pointer);
  200.       varArray:    (VArray: PVarArray);
  201.       varByRef:    (VPointer: Pointer);
  202.   end;
  203.  
  204.   PShortString = ^ShortString;
  205.   PAnsiString = ^AnsiString;
  206.   PWideString = ^WideString;
  207.   PString = PAnsiString;
  208.  
  209.   PExtended = ^Extended;
  210.   PCurrency = ^Currency;
  211.   PVariant = ^Variant;
  212.  
  213.   TDateTime = type Double;
  214.  
  215.   PVarRec = ^TVarRec;
  216.   TVarRec = record
  217.     case Byte of
  218.       vtInteger:    (VInteger: Integer; VType: Byte);
  219.       vtBoolean:    (VBoolean: Boolean);
  220.       vtChar:       (VChar: Char);
  221.       vtExtended:   (VExtended: PExtended);
  222.       vtString:     (VString: PShortString);
  223.       vtPointer:    (VPointer: Pointer);
  224.       vtPChar:      (VPChar: PChar);
  225.       vtObject:     (VObject: TObject);
  226.       vtClass:      (VClass: TClass);
  227.       vtWideChar:   (VWideChar: WideChar);
  228.       vtPWideChar:  (VPWideChar: PWideChar);
  229.       vtAnsiString: (VAnsiString: Pointer);
  230.       vtCurrency:   (VCurrency: PCurrency);
  231.       vtVariant:    (VVariant: PVariant);
  232.       vtInterface:  (VInterface: Pointer);
  233.   end;
  234.  
  235.   PMemoryManager = ^TMemoryManager;
  236.   TMemoryManager = record
  237.     GetMem: function(Size: Integer): Pointer;
  238.     FreeMem: function(P: Pointer): Integer;
  239.     ReallocMem: function(P: Pointer; Size: Integer): Pointer;
  240.   end;
  241.  
  242.   THeapStatus = record
  243.     TotalAddrSpace: Cardinal;
  244.     TotalUncommitted: Cardinal;
  245.     TotalCommitted: Cardinal;
  246.     TotalAllocated: Cardinal;
  247.     TotalFree: Cardinal;
  248.     FreeSmall: Cardinal;
  249.     FreeBig: Cardinal;
  250.     Unused: Cardinal;
  251.     Overhead: Cardinal;
  252.     HeapErrorCode: Cardinal;
  253.   end;
  254.  
  255.   PackageUnitEntry = record
  256.     Init, FInit : procedure;
  257.   end;
  258.  
  259.   { Compiler generated table to be processed sequentially to init & finit all package units }
  260.   { Init: 0..Max-1; Final: Last Initialized..0                                              }
  261.   UnitEntryTable = array [0..9999999] of PackageUnitEntry;
  262.   PUnitEntryTable = ^UnitEntryTable;
  263.  
  264.   PackageInfoTable = record
  265.     UnitCount : Integer;      { number of entries in UnitInfo array; always > 0 }
  266.     UnitInfo : PUnitEntryTable;
  267.   end;
  268.  
  269.   PackageInfo = ^PackageInfoTable;
  270.  
  271.   { Each package exports a '@GetPackageInfoTable' which can be used to retrieve }
  272.   { the table which contains compiler generated information about the package DLL }
  273.   GetPackageInfoTable = function : PackageInfo;
  274.  
  275. threadvar
  276.  
  277.   RaiseList: Pointer;     { Stack of current exception objects }
  278.   InOutRes: Integer;      { Result of I/O operations }
  279.  
  280. var
  281.  
  282.   ExceptProc: Pointer;    { Unhandled exception handler }
  283.   ErrorProc: Pointer;     { Error handler procedure }
  284.   ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference }
  285.   ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance }
  286.   ExceptionClass: TClass; { Exception base class (must be Exception) }
  287.   SafeCallErrorProc: Pointer; { Safecall error handler }
  288.   AssertErrorProc: Pointer; { Assertion error handler }
  289.   HPrevInst: Longint;     { Handle of previous instance }
  290.   MainInstance: Longint;  { Handle of the main(.EXE) HInstance }
  291.   IsLibrary: Boolean;     { True if module is a DLL }
  292.   CmdShow: Integer;       { CmdShow parameter for CreateWindow }
  293.   CmdLine: PChar;         { Command line pointer }
  294.   InitProc: Pointer;      { Last installed initialization procedure }
  295.   ExitCode: Integer;      { Program result }
  296.   ExitProc: Pointer;      { Last installed exit procedure }
  297.   ErrorAddr: Pointer;     { Address of run-time error }
  298.   RandSeed: Longint;      { Base for random number generator }
  299.   IsConsole: Boolean;     { True if compiled as console app }
  300.   IsMultiThread: Boolean; { True if more than one thread }
  301.   FileMode: Byte;         { Standard mode for opening files }
  302.   Test8086: Byte;         { Will always be 2 (386 or later) }
  303.   Test8087: Byte;         { Will always be 3 (387 or later) }
  304.   TestFDIV: Shortint;     { -1: Flawed Pentium, 0: Not determined, 1: Ok }
  305.   Input: Text;            { Standard input }
  306.   Output: Text;           { Standard output }
  307.  
  308.  
  309. var
  310.   Default8087CW: Word = $1332;{ Default 8087 control word.  FPU control
  311.                                 register is set to this value.
  312.                                 CAUTION:  Setting this to an invalid value
  313.                                           could cause unpredictable behaiour. }
  314.   HeapAllocFlags: Word = 2;   { Heap allocation flags, gmem_Moveable }
  315.   DebugHook: Byte = 0;        {  1 to notify debugger of non-Delphi exceptions
  316.                                  >1 to notify debugger of exception unwinding }
  317.  
  318. var
  319.   Unassigned: Variant;    { Unassigned standard constant }
  320.   Null: Variant;          { Null standard constant }
  321.  
  322.   AllocMemCount: Integer; { Number of allocated memory blocks }
  323.   AllocMemSize: Integer;  { Total size of allocated memory blocks }
  324.  
  325. { Memory manager support }
  326.  
  327. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  328. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  329. function IsMemoryManagerSet: Boolean;
  330.  
  331. function SysGetMem(Size: Integer): Pointer;
  332. function SysFreeMem(P: Pointer): Integer;
  333. function SysReallocMem(P: Pointer; Size: Integer): Pointer;
  334.  
  335. function GetHeapStatus: THeapStatus;
  336.  
  337. { Thread support }
  338. type
  339.   TThreadFunc = function(Parameter: Pointer): Integer;
  340.  
  341. function BeginThread(SecurityAttributes: Pointer; StackSize: Integer;
  342.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  343.                      CreationFlags: Integer; var ThreadId: Integer): Integer;
  344.  
  345. procedure EndThread(ExitCode: Integer);
  346.  
  347. { Standard procedures and functions }
  348.  
  349. procedure _ChDir(const S: string);
  350. procedure __Flush(var F: Text);
  351. procedure _LGetDir(D: Byte; var S: string);
  352. procedure _SGetDir(D: Byte; var S: ShortString);
  353. function IOResult: Integer;
  354. procedure _MkDir(const S: string);
  355. procedure Move(const Source; var Dest; Count: Integer);
  356. function ParamCount: Integer;
  357. function ParamStr(Index: Integer): string;
  358. procedure Randomize;
  359. procedure _RmDir(const S: string);
  360. function UpCase(Ch: Char): Char;
  361.  
  362. { Wide character support procedures and functions }
  363.  
  364. function WideCharToString(Source: PWideChar): string;
  365. function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
  366. procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
  367. procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  368.   var Dest: string);
  369. function StringToWideChar(const Source: string; Dest: PWideChar;
  370.   DestSize: Integer): PWideChar;
  371.  
  372. { OLE string support procedures and functions }
  373.  
  374. function OleStrToString(Source: PWideChar): string;
  375. procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
  376. function StringToOleStr(const Source: string): PWideChar;
  377.  
  378. { Variant support procedures and functions }
  379.  
  380. procedure VarClear(var V);
  381. procedure VarCopy(var Dest; const Source: Variant);
  382. procedure VarCast(var Dest; const Source: Variant; VarType: Integer);
  383. function VarType(const V: Variant): Integer;
  384. function VarAsType(const V: Variant; VarType: Integer): Variant;
  385. function VarIsEmpty(const V: Variant): Boolean;
  386. function VarIsNull(const V: Variant): Boolean;
  387. function VarToStr(const V: Variant): string;
  388. function VarFromDateTime(DateTime: TDateTime): Variant;
  389. function VarToDateTime(const V: Variant): TDateTime;
  390.  
  391. { Variant array support procedures and functions }
  392.  
  393. function VarArrayCreate(const Bounds: array of Integer;
  394.   VarType: Integer): Variant;
  395. function VarArrayOf(const Values: array of Variant): Variant;
  396. procedure VarArrayRedim(var A; HighBound: Integer);
  397. function VarArrayDimCount(const A: Variant): Integer;
  398. function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
  399. function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
  400. function VarArrayLock(const A: Variant): Pointer;
  401. procedure VarArrayUnlock(const A: Variant);
  402. function VarArrayRef(const A: Variant): Variant;
  403. function VarIsArray(const A: Variant): Boolean;
  404.  
  405. { Variant IDispatch call support }
  406.  
  407. procedure _DispInvokeError;
  408.  
  409. var
  410.   VarDispProc: Pointer = @_DispInvokeError;
  411.   DispCallByIDProc: Pointer = @_DispInvokeError;
  412.  
  413. { Package/Module registration and unregistration }
  414.  
  415. type
  416.   PLibModule = ^TLibModule;
  417.   TLibModule = record
  418.     Next: PLibModule;
  419.     Instance: Longint;
  420.     ResInstance: Longint;
  421.     Reserved: Integer;
  422.   end;
  423.  
  424.   TEnumModuleFunc = function (HInstance: Longint; Data: Pointer): Boolean;
  425.   TModuleUnloadProc = procedure (HInstance: Longint);
  426.  
  427.   PModuleUnloadRec = ^TModuleUnloadRec;
  428.   TModuleUnloadRec = record
  429.     Next: PModuleUnloadRec;
  430.     Proc: TModuleUnloadProc;
  431.   end;
  432.  
  433. var
  434.   LibModuleList: PLibModule = nil;
  435.   ModuleUnloadList: PModuleUnloadRec = nil;
  436.  
  437. procedure RegisterModule(LibModule: PLibModule);
  438. procedure UnregisterModule(LibModule: PLibModule);
  439. function FindHInstance(Address: Pointer): Longint;
  440. function FindClassHInstance(ClassType: TClass): Longint;
  441. function FindResourceHInstance(Instance: Longint): Longint;
  442. procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer);
  443. procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
  444. procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
  445. procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
  446.  
  447. { ResString support function/record }
  448.  
  449. type
  450.   PResStringRec = ^TResStringRec;
  451.   TResStringRec = record
  452.     Module: ^Longint;
  453.     Identifier: Integer;
  454.   end;
  455.  
  456. function LoadResString(ResStringRec: PResStringRec): string;
  457.  
  458. { Procedures and functions that need compiler magic }
  459.  
  460. procedure _COS;
  461. procedure _EXP;
  462. procedure _INT;
  463. procedure _SIN;
  464. procedure _FRAC;
  465. procedure _ROUND;
  466. procedure _TRUNC;
  467.  
  468. procedure _AbstractError;
  469. procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
  470. procedure _Append;
  471. procedure _Assign(var T: Text; S: ShortString);
  472. procedure _BlockRead;
  473. procedure _BlockWrite;
  474. procedure _Close;
  475. procedure _PStrCat;
  476. procedure _PStrNCat;
  477. procedure _PStrCpy;
  478. procedure _PStrNCpy;
  479. procedure _EofFile;
  480. procedure _EofText;
  481. procedure _Eoln;
  482. procedure _Erase;
  483. procedure _FilePos;
  484. procedure _FileSize;
  485. procedure _FillChar;
  486. procedure _FreeMem;
  487. procedure _GetMem;
  488. procedure _ReallocMem;
  489. procedure _Halt;
  490. procedure _Halt0;
  491. procedure _Mark;
  492. procedure _PStrCmp;
  493. procedure _AStrCmp;
  494. procedure _RandInt;
  495. procedure _RandExt;
  496. procedure _ReadRec;
  497. procedure _ReadChar;
  498. procedure _ReadLong;
  499. procedure _ReadString;
  500. procedure _ReadCString;
  501. procedure _ReadLString;
  502. procedure _ReadExt;
  503. procedure _ReadLn;
  504. procedure _Rename;
  505. procedure _Release;
  506. procedure _ResetText(var T: Text);
  507. procedure _ResetFile;
  508. procedure _RewritText(var T: Text);
  509. procedure _RewritFile;
  510. procedure _RunError;
  511. procedure _Run0Error;
  512. procedure _Seek;
  513. procedure _SeekEof;
  514. procedure _SeekEoln;
  515. procedure _SetTextBuf;
  516. procedure _StrLong;
  517. procedure _Str0Long;
  518. procedure _Truncate;
  519. procedure _ValLong;
  520. procedure _WriteRec;
  521. procedure _WriteChar;
  522. procedure _Write0Char;
  523. procedure _WriteBool;
  524. procedure _Write0Bool;
  525. procedure _WriteLong;
  526. procedure _Write0Long;
  527. procedure _WriteString;
  528. procedure _Write0String;
  529. procedure _WriteCString;
  530. procedure _Write0CString;
  531. procedure _WriteLString;
  532. procedure _Write0LString;
  533. function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
  534. function _Write0Variant(var T: Text; const V: Variant): Pointer;
  535. procedure _Write2Ext;
  536. procedure _Write1Ext;
  537. procedure _Write0Ext;
  538. procedure _WriteLn;
  539.  
  540. procedure __CToPasStr;
  541. procedure __CLenToPasStr;
  542. procedure __ArrayToPasStr;
  543. procedure __PasToCStr;
  544.  
  545. procedure __IOTest;
  546. procedure _Flush(var F: Text);
  547.  
  548. procedure _SetElem;
  549. procedure _SetRange;
  550. procedure _SetEq;
  551. procedure _SetLe;
  552. procedure _SetIntersect;
  553. procedure _SetUnion;
  554. procedure _SetSub;
  555. procedure _SetExpand;
  556.  
  557. procedure _Str2Ext;
  558. procedure _Str0Ext;
  559. procedure _Str1Ext;
  560. procedure _ValExt;
  561. procedure _Pow10;
  562. procedure _Real2Ext;
  563. procedure _Ext2Real;
  564.  
  565. procedure _ObjSetup;
  566. procedure _ObjCopy;
  567. procedure _Fail;
  568. procedure _BoundErr;
  569. procedure _IntOver;
  570. procedure _StartExe;
  571. procedure _StartLib;
  572. procedure _PackageLoad  (const Table : PackageInfo);
  573. procedure _PackageUnload(const Table : PackageInfo);
  574. procedure _InitResStrings;
  575.  
  576. procedure _ClassCreate;
  577. procedure _ClassDestroy;
  578. procedure _IsClass;
  579. procedure _AsClass;
  580.  
  581. procedure _RaiseExcept;
  582. procedure _RaiseAgain;
  583. procedure _DoneExcept;
  584. procedure _TryFinallyExit;
  585.  
  586. procedure _CallDynaInst;
  587. procedure _CallDynaClass;
  588. procedure _FindDynaInst;
  589. procedure _FindDynaClass;
  590.  
  591. procedure _LStrClr(var S: AnsiString);
  592. procedure _LStrArrayClr{var str: AnsiString; cnt: longint};
  593. procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
  594. procedure _LStrLAsg{var dest: AnsiString; source: AnsiString};
  595. procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  596. procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  597. procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
  598. procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
  599. procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
  600. procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
  601. procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
  602. procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  603. procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  604. procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
  605. procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
  606. function _LStrLen{str: AnsiString}: Longint;
  607. procedure _LStrCat{var dest: AnsiString; source: AnsiString};
  608. procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
  609. procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
  610. procedure _LStrCmp{left: AnsiString; right: AnsiString};
  611. procedure _LStrAddRef{str: AnsiString};
  612. procedure _LStrToPChar{str: AnsiString): PChar};
  613. procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString};
  614. procedure _Delete{ var s : openstring; index, count : Integer };
  615. procedure _Insert{ source : ShortString; var s : openstring; index : Integer };
  616. procedure _Pos{ substr : ShortString; s : ShortString ) : Integer};
  617. procedure _SetLength{var s: ShortString; newLength: Integer};
  618. procedure _SetString{var s: ShortString: buffer: PChar; len: Integer};
  619.  
  620. procedure UniqueString(var str: string);
  621. procedure _NewAnsiString{length: Longint};      { for debugger purposes only }
  622.  
  623. procedure _LStrCopy  { const s : AnsiString; index, count : Integer) : AnsiString};
  624. procedure _LStrDelete{ var s : AnsiString; index, count : Integer };
  625. procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
  626. procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
  627. procedure _LStrSetLength{ var str: AnsiString; newLength: Integer};
  628. procedure _LStrOfChar{ c: Char; count: Integer): AnsiString };
  629.  
  630. procedure _WStrClr(var S: WideString);
  631. procedure _WStrArrayClr(var StrArray; Count: Integer);
  632. procedure _WStrAsg(var Dest: WideString; const Source: WideString);
  633. procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  634. procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
  635. procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
  636. procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
  637. procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
  638. procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
  639. procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
  640. procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  641. procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
  642. procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
  643. procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
  644. function _WStrToPWChar(const S: WideString): PWideChar;
  645. function _WStrLen(const S: WideString): Integer;
  646. procedure _WStrCat(var Dest: WideString; const Source: WideString);
  647. procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
  648. procedure _WStrCatN{var dest:WideString; argCnt: Integer; ...};
  649. procedure _WStrCmp{left: WideString; right: WideString};
  650. function _NewWideString(Length: Integer): PWideChar;
  651. function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
  652. procedure _WStrDelete(var S: WideString; Index, Count: Integer);
  653. procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
  654. procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
  655. procedure _WStrSetLength(var S: WideString; NewLength: Integer);
  656. function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
  657. procedure _WStrAddRef{var str: WideString};
  658.  
  659. procedure _Initialize;
  660. procedure _InitializeArray;
  661. procedure _InitializeRecord;
  662. procedure _Finalize;
  663. procedure _FinalizeArray;
  664. procedure _FinalizeRecord;
  665. procedure _AddRef;
  666. procedure _AddRefArray;
  667. procedure _AddRefRecord;
  668. procedure _CopyArray;
  669. procedure _CopyRecord;
  670. procedure _CopyObject;
  671.  
  672. procedure _New;
  673. procedure _Dispose;
  674.  
  675. procedure _DispInvoke; cdecl;
  676. procedure _IntfDispCall; cdecl;
  677. procedure _IntfVarCall; cdecl;
  678.  
  679. procedure _VarToInt;
  680. procedure _VarToBool;
  681. procedure _VarToReal;
  682. procedure _VarToCurr;
  683. procedure _VarToPStr(var S; const V: Variant);
  684. procedure _VarToLStr(var S: string; const V: Variant);
  685. procedure _VarToWStr(var S: WideString; const V: Variant);
  686. procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
  687. procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
  688.  
  689. procedure _VarFromInt;
  690. procedure _VarFromBool;
  691. procedure _VarFromReal;
  692. procedure _VarFromTDateTime;
  693. procedure _VarFromCurr;
  694. procedure _VarFromPStr(var V: Variant; const Value: ShortString);
  695. procedure _VarFromLStr(var V: Variant; const Value: string);
  696. procedure _VarFromWStr(var V: Variant; const Value: WideString);
  697. procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
  698. procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
  699. procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
  700. procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
  701. procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
  702.  
  703. procedure _VarAdd;
  704. procedure _VarSub;
  705. procedure _VarMul;
  706. procedure _VarDiv;
  707. procedure _VarMod;
  708. procedure _VarAnd;
  709. procedure _VarOr;
  710. procedure _VarXor;
  711. procedure _VarShl;
  712. procedure _VarShr;
  713. procedure _VarRDiv;
  714. procedure _VarCmp;
  715.  
  716. procedure _VarNeg;
  717. procedure _VarNot;
  718.  
  719. procedure _VarCopy;
  720. procedure _VarClr;
  721. procedure _VarAddRef;
  722.  
  723. procedure _IntfClear(var Dest: IUnknown);
  724. procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
  725. procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
  726. procedure _IntfAddRef(const Dest: IUnknown);
  727.  
  728. function _VarArrayGet(var A: Variant; IndexCount: Integer;
  729.   Indices: Integer): Variant; cdecl;
  730. procedure _VarArrayPut(var A: Variant; const Value: Variant;
  731.   IndexCount: Integer; Indices: Integer); cdecl;
  732.  
  733. procedure _HandleAnyException;
  734. procedure _HandleOnException;
  735. procedure _HandleFinally;
  736. procedure _HandleAutoException;
  737.  
  738. procedure _FSafeDivide;
  739. procedure _FSafeDivideR;
  740.  
  741. procedure _CheckAutoResult;
  742.  
  743. procedure FPower10;
  744.  
  745. procedure TextStart;
  746.  
  747. (* =================================================================== *)
  748.  
  749. implementation
  750.  
  751. uses
  752.   SysInit;
  753.  
  754. { Internal runtime error codes }
  755.  
  756. const
  757.   reOutOfMemory       = 1;
  758.   reInvalidPtr        = 2;
  759.   reDivByZero         = 3;
  760.   reRangeError        = 4;
  761.   reIntOverflow       = 5;
  762.   reInvalidOp         = 6;
  763.   reZeroDivide        = 7;
  764.   reOverflow          = 8;
  765.   reUnderflow         = 9;
  766.   reInvalidCast       = 10;
  767.   reAccessViolation   = 11;
  768.   reStackOverflow     = 12;
  769.   reControlBreak      = 13;
  770.   rePrivInstruction   = 14;
  771.   reVarTypeCast       = 15;
  772.   reVarInvalidOp      = 16;
  773.   reVarDispatch       = 17;
  774.   reVarArrayCreate    = 18;
  775.   reVarNotArray       = 19;
  776.   reVarArrayBounds    = 20;
  777.   reAssertionFailed   = 21;
  778.   reExternalException = 22;     { not used here; in SysUtils }
  779.   reIntfCastError     = 23;
  780.   reSafeCallError     = 24;
  781.  
  782. { this procedure should be at the very beginning of the }
  783. { text segment. it is only used by _RunError to find    }
  784. { start address of the text segment so a nice error     }
  785. { location can be shown.                                                                }
  786.  
  787. procedure TextStart;
  788. begin
  789. end;
  790.  
  791. { ----------------------------------------------------- }
  792. {       NT Calls necessary for the .asm files           }
  793. { ----------------------------------------------------- }
  794.  
  795. type
  796.   PMemInfo = ^TMemInfo;
  797.   TMemInfo = packed record
  798.     BaseAddress: Pointer;
  799.     AllocationBase: Pointer;
  800.     AllocationProtect: Longint;
  801.     RegionSize: Longint;
  802.     State: Longint;
  803.     Protect: Longint;
  804.     Type_9 : Longint;
  805.   end;
  806.  
  807.   PStartupInfo = ^TStartupInfo;
  808.   TStartupInfo = record
  809.     cb: Longint;
  810.     lpReserved: Pointer;
  811.     lpDesktop: Pointer;
  812.     lpTitle: Pointer;
  813.     dwX: Longint;
  814.     dwY: Longint;
  815.     dwXSize: Longint;
  816.     dwYSize: Longint;
  817.     dwXCountChars: Longint;
  818.     dwYCountChars: Longint;
  819.     dwFillAttribute: Longint;
  820.     dwFlags: Longint;
  821.     wShowWindow: Word;
  822.     cbReserved2: Word;
  823.     lpReserved2: ^Byte;
  824.     hStdInput: Integer;
  825.     hStdOutput: Integer;
  826.     hStdError: Integer;
  827.   end;
  828.  
  829. const
  830.   kernel = 'kernel32.dll';
  831.   user = 'user32.dll';
  832.   oleaut = 'oleaut32.dll';
  833.  
  834. procedure CloseHandle;                  external kernel name 'CloseHandle';
  835. procedure CreateFileA;                  external kernel name 'CreateFileA';
  836. procedure DeleteFileA;                  external kernel name 'DeleteFileA';
  837. procedure GetFileType;                  external kernel name 'GetFileType';
  838. procedure GetSystemTime;                external kernel name 'GetSystemTime';
  839. procedure GetFileSize;                  external kernel name 'GetFileSize';
  840. procedure GetStdHandle;                 external kernel name 'GetStdHandle';
  841. //procedure GetStartupInfo;               external kernel name 'GetStartupInfo';
  842. procedure MoveFileA;                    external kernel name 'MoveFileA';
  843. procedure RaiseException;               external kernel name 'RaiseException';
  844. procedure ReadFile;                     external kernel name 'ReadFile';
  845. procedure RtlUnwind;                    external kernel name 'RtlUnwind';
  846. procedure SetEndOfFile;                 external kernel name 'SetEndOfFile';
  847. procedure SetFilePointer;               external kernel name 'SetFilePointer';
  848. procedure WriteFile;                    external kernel name 'WriteFile';
  849.  
  850. function CreateThread(SecurityAttributes: Pointer; StackSize: Integer;
  851.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  852.                      CreationFlags: Integer; var ThreadId: Integer): Integer; stdcall;
  853.   external kernel name 'CreateThread';
  854.  
  855. procedure ExitThread(ExitCode: Integer); stdcall;
  856.   external kernel name 'ExitThread';
  857.  
  858. procedure ExitProcess(ExitCode: Integer); stdcall;
  859.   external kernel name 'ExitProcess';
  860.  
  861. procedure MessageBox(Wnd: Integer; Text: PChar; Caption: PChar; Typ: Integer); stdcall;
  862.   external user   name 'MessageBoxA';
  863.  
  864. function CreateDirectory(PathName: PChar; Attr: Integer): WordBool; stdcall;
  865.   external kernel name 'CreateDirectoryA';
  866.  
  867. function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
  868.   external kernel name 'FreeLibrary';
  869.  
  870. function GetCommandLine: PChar; stdcall;
  871.   external kernel name 'GetCommandLineA';
  872.  
  873. function GetCurrentDirectory(BufSize: Integer; Buffer: PChar): Integer; stdcall;
  874.   external kernel name 'GetCurrentDirectoryA';
  875.  
  876. function GetLastError: Integer; stdcall;
  877.   external kernel name 'GetLastError';
  878.  
  879. function GetModuleFileName(Module: Integer; Filename: PChar;
  880.   Size: Integer): Integer; stdcall;
  881.   external kernel name 'GetModuleFileNameA';
  882.  
  883. //function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
  884. //  external kernel name 'GetModuleHandleA';
  885.  
  886. procedure GetStartupInfo(var lpStartupInfo: TStartupInfo); stdcall;
  887.   external kernel name 'GetStartupInfoA';
  888.  
  889. function LoadString(Instance: Longint; IDent: Integer; Buffer: PChar;
  890.   Size: Integer): Integer; stdcall;
  891.   external user name 'LoadStringA';
  892.  
  893. function MultiByteToWideChar(CodePage, Flags: Integer; MBStr: PChar;
  894.   MBCount: Integer; WCStr: PWideChar; WCCount: Integer): Integer; stdcall;
  895.   external kernel name 'MultiByteToWideChar';
  896.  
  897. function RemoveDirectory(PathName: PChar): WordBool; stdcall;
  898.   external kernel name 'RemoveDirectoryA';
  899.  
  900. function SetCurrentDirectory(PathName: PChar): WordBool; stdcall;
  901.   external kernel name 'SetCurrentDirectoryA';
  902.  
  903. function WideCharToMultiByte(CodePage, Flags: Integer; WCStr: PWideChar;
  904.   WCCount: Integer; MBStr: PChar; MBCount: Integer; DefaultChar: PChar;
  905.   UsedDefaultChar: Pointer): Integer; stdcall;
  906.   external kernel name 'WideCharToMultiByte';
  907.  
  908. function VirtualQuery(lpAddress: Pointer;
  909.   var lpBuffer: TMemInfo; dwLength: Longint): Longint; stdcall;
  910.   external kernel name 'VirtualQuery';
  911.  
  912. //function SysAllocString(P: PWideChar): PWideChar; stdcall;
  913. //  external oleaut name 'SysAllocString';
  914.  
  915. function SysAllocStringLen(P: PWideChar; Len: Integer): PWideChar; stdcall;
  916.   external oleaut name 'SysAllocStringLen';
  917.  
  918. function SysReAllocStringLen(var S: WideString; P: PWideChar;
  919.   Len: Integer): LongBool; stdcall;
  920.   external oleaut name 'SysReAllocStringLen';
  921.  
  922. procedure SysFreeString(const S: WideString); stdcall;
  923.   external oleaut name 'SysFreeString';
  924.  
  925. function SysStringLen(const S: WideString): Integer; stdcall;
  926.   external oleaut name 'SysStringLen';
  927.  
  928. //procedure VariantInit(var V: Variant); stdcall;
  929. //  external oleaut name 'VariantInit';
  930.  
  931. function VariantClear(var V: Variant): Integer; stdcall;
  932.   external oleaut name 'VariantClear';
  933.  
  934. //function VariantCopy(var Dest: Variant; const Source: Variant): Integer; stdcall;
  935. //  external oleaut name 'VariantCopy';
  936.  
  937. function VariantCopyInd(var Dest: Variant; const Source: Variant): Integer; stdcall;
  938.   external oleaut name 'VariantCopyInd';
  939.  
  940. //function VariantChangeType(var Dest: Variant; const Source: Variant;
  941. //  Flags: Word; VarType: Word): Integer; stdcall;
  942. //  external oleaut name 'VariantChangeType';
  943.  
  944. function VariantChangeTypeEx(var Dest: Variant; const Source: Variant;
  945.   LCID: Integer; Flags: Word; VarType: Word): Integer; stdcall;
  946.   external oleaut name 'VariantChangeTypeEx';
  947.  
  948. function SafeArrayCreate(VarType, DimCount: Integer;
  949.   const Bounds): PVarArray; stdcall;
  950.   external oleaut name 'SafeArrayCreate';
  951.  
  952. function SafeArrayRedim(VarArray: PVarArray;
  953.   var NewBound: TVarArrayBound): Integer; stdcall;
  954.   external oleaut name 'SafeArrayRedim';
  955.  
  956. function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer;
  957.   var LBound: Integer): Integer; stdcall;
  958.   external oleaut name 'SafeArrayGetLBound';
  959.  
  960. function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer;
  961.   var UBound: Integer): Integer; stdcall;
  962.   external oleaut name 'SafeArrayGetUBound';
  963.  
  964. function SafeArrayAccessData(VarArray: PVarArray;
  965.   var Data: Pointer): Integer; stdcall;
  966.   external oleaut name 'SafeArrayAccessData';
  967.  
  968. function SafeArrayUnaccessData(VarArray: PVarArray): Integer; stdcall;
  969.   external oleaut name 'SafeArrayUnaccessData';
  970.  
  971. function SafeArrayGetElement(VarArray: PVarArray; Indices,
  972.   Data: Pointer): Integer; stdcall;
  973.   external oleaut name 'SafeArrayGetElement';
  974.  
  975. function SafeArrayPutElement(VarArray: PVarArray; Indices,
  976.   Data: Pointer): Integer; stdcall;
  977.   external oleaut name 'SafeArrayPutElement';
  978.  
  979. function GetCmdShow: Integer;
  980. var
  981.   SI: TStartupInfo;
  982. begin
  983.   Result := 10;                  { SW_SHOWDEFAULT }
  984.   GetStartupInfo(SI);
  985.   if SI.dwFlags and 1 <> 0 then  { STARTF_USESHOWWINDOW }
  986.     Result := SI.wShowWindow;
  987. end;
  988.  
  989. { ----------------------------------------------------- }
  990. {       Memory manager                                                                          }
  991. { ----------------------------------------------------- }
  992.  
  993. procedure Error(errorCode: Byte); forward;
  994.  
  995. {$I GETMEM.INC }
  996.  
  997. var
  998.   MemoryManager: TMemoryManager = (
  999.     GetMem: SysGetMem;
  1000.     FreeMem: SysFreeMem;
  1001.     ReallocMem: SysReallocMem);
  1002.  
  1003. procedure _GetMem;
  1004. asm
  1005.         TEST    EAX,EAX
  1006.         JE      @@1
  1007.         CALL    MemoryManager.GetMem
  1008.         OR      EAX,EAX
  1009.         JE      @@2
  1010. @@1:    RET
  1011. @@2:    MOV     AL,reOutOfMemory
  1012.         JMP     Error
  1013. end;
  1014.  
  1015. procedure _FreeMem;
  1016. asm
  1017.         TEST    EAX,EAX
  1018.         JE      @@1
  1019.         CALL    MemoryManager.FreeMem
  1020.         OR      EAX,EAX
  1021.         JNE     @@2
  1022. @@1:    RET
  1023. @@2:    MOV     AL,reInvalidPtr
  1024.         JMP     Error
  1025. end;
  1026.  
  1027. procedure _ReallocMem;
  1028. asm
  1029.         MOV     ECX,[EAX]
  1030.         TEST    ECX,ECX
  1031.         JE      @@alloc
  1032.         TEST    EDX,EDX
  1033.         JE      @@free
  1034. @@resize:
  1035.         PUSH    EAX
  1036.         MOV     EAX,ECX
  1037.         CALL    MemoryManager.ReallocMem
  1038.         POP     ECX
  1039.         OR      EAX,EAX
  1040.         JE      @@allocError
  1041.         MOV     [ECX],EAX
  1042.         RET
  1043. @@freeError:
  1044.         MOV     AL,reInvalidPtr
  1045.         JMP     Error
  1046. @@free:
  1047.         MOV     [EAX],EDX
  1048.         MOV     EAX,ECX
  1049.         CALL    MemoryManager.FreeMem
  1050.         OR      EAX,EAX
  1051.         JNE     @@freeError
  1052.         RET
  1053. @@allocError:
  1054.         MOV     AL,reOutOfMemory
  1055.         JMP     Error
  1056. @@alloc:
  1057.         TEST    EDX,EDX
  1058.         JE      @@exit
  1059.         PUSH    EAX
  1060.         MOV     EAX,EDX
  1061.         CALL    MemoryManager.GetMem
  1062.         POP     ECX
  1063.         OR      EAX,EAX
  1064.         JE      @@allocError
  1065.         MOV     [ECX],EAX
  1066. @@exit:
  1067. end;
  1068.  
  1069. procedure GetMemoryManager(var MemMgr: TMemoryManager);
  1070. begin
  1071.   MemMgr := MemoryManager;
  1072. end;
  1073.  
  1074. procedure SetMemoryManager(const MemMgr: TMemoryManager);
  1075. begin
  1076.   MemoryManager := MemMgr;
  1077. end;
  1078.  
  1079. function IsMemoryManagerSet: Boolean;
  1080. begin
  1081.   with MemoryManager do
  1082.     Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or
  1083.       (@ReallocMem <> @SysReallocMem);
  1084. end;
  1085.  
  1086. { ----------------------------------------------------- }
  1087. {    local functions & procedures of the system unit    }
  1088. { ----------------------------------------------------- }
  1089.  
  1090. procedure Error(errorCode: Byte);
  1091. asm
  1092.         AND     EAX,127
  1093.         MOV     ECX,ErrorProc
  1094.         TEST    ECX,ECX
  1095.         JE      @@term
  1096.         POP     EDX
  1097.         CALL    ECX
  1098. @@term:
  1099.         DEC     EAX
  1100.         MOV     AL,byte ptr @@errorTable[EAX]
  1101.         JNS     @@skip
  1102.         CALL    SysInit.@GetTLS
  1103.         MOV     EAX,[EAX].InOutRes
  1104. @@skip:
  1105.         JMP     _RunError
  1106.  
  1107. @@errorTable:
  1108.         DB      203     { reOutOfMemory }
  1109.         DB      204     { reInvalidPtr }
  1110.         DB      200     { reDivByZero }
  1111.         DB      201     { reRangeError }
  1112. {               210       abstract error }
  1113.         DB      215     { reIntOverflow }
  1114.         DB      207     { reInvalidOp }
  1115.         DB      200     { reZeroDivide }
  1116.         DB      205     { reOverflow }
  1117.         DB      206     { reUnderflow }
  1118.         DB      219     { reInvalidCast }
  1119.         DB      216     { Access violation }
  1120.         DB      202     { Stack overflow }
  1121.         DB      217     { Control-C }
  1122.         DB      218     { Privileged instruction }
  1123.         DB      220     { Invalid variant type cast }
  1124.         DB      221     { Invalid variant operation }
  1125.         DB      222     { No variant method call dispatcher }
  1126.         DB      223     { Cannot create variant array }
  1127.         DB      224     { Variant does not contain an array }
  1128.         DB      225     { Variant array bounds error }
  1129. {               226       thread init failure }
  1130.         DB      227     { reAssertionFailed }
  1131.         DB      0       { reExternalException not used here; in SysUtils }
  1132.         DB      228     { reIntfCastError }
  1133.         DB      229     { reSafeCallError }
  1134. end;
  1135.  
  1136. procedure       __IOTest;
  1137. asm
  1138.         PUSH    EAX
  1139.         PUSH    EDX
  1140.         PUSH    ECX
  1141.         CALL    SysInit.@GetTLS
  1142.         CMP     [EAX].InOutRes,0
  1143.         POP     ECX
  1144.         POP     EDX
  1145.         POP     EAX
  1146.         JNE     @error
  1147.         RET
  1148. @error:
  1149.         XOR     EAX,EAX
  1150.         JMP     Error
  1151. end;
  1152.  
  1153. procedure SetInOutRes;
  1154. asm
  1155.         PUSH    EAX
  1156.         CALL    SysInit.@GetTLS
  1157.         POP     [EAX].InOutRes
  1158. end;
  1159.  
  1160.  
  1161. procedure InOutError;
  1162. asm
  1163.         CALL    GetLastError
  1164.         JMP     SetInOutRes
  1165. end;
  1166.  
  1167. procedure _ChDir(const S: string);
  1168. begin
  1169.   if not SetCurrentDirectory(PChar(S)) then InOutError;
  1170. end;
  1171.  
  1172. procedure       _Copy{ s : ShortString; index, count : Integer ) : ShortString};
  1173. asm
  1174. {     ->EAX     Source string                   }
  1175. {       EDX     index                           }
  1176. {       ECX     count                           }
  1177. {       [ESP+4] Pointer to result string        }
  1178.  
  1179.         PUSH    ESI
  1180.         PUSH    EDI
  1181.  
  1182.         MOV     ESI,EAX
  1183.         MOV     EDI,[ESP+8+4]
  1184.  
  1185.         XOR     EAX,EAX
  1186.         OR      AL,[ESI]
  1187.         JZ      @@srcEmpty
  1188.  
  1189. {       limit index to satisfy 1 <= index <= Length(src) }
  1190.  
  1191.         TEST    EDX,EDX
  1192.         JLE     @@smallInx
  1193.         CMP     EDX,EAX
  1194.         JG      @@bigInx
  1195. @@cont1:
  1196.  
  1197. {       limit count to satisfy 0 <= count <= Length(src) - index + 1    }
  1198.  
  1199.         SUB     EAX,EDX { calculate Length(src) - index + 1     }
  1200.         INC     EAX
  1201.         TEST    ECX,ECX
  1202.         JL      @@smallCount
  1203.         CMP     ECX,EAX
  1204.         JG      @@bigCount
  1205. @@cont2:
  1206.  
  1207.         ADD     ESI,EDX
  1208.  
  1209.         MOV     [EDI],CL
  1210.         INC     EDI
  1211.         REP     MOVSB
  1212.         JMP     @@exit
  1213.  
  1214. @@smallInx:
  1215.         MOV     EDX,1
  1216.         JMP     @@cont1
  1217. @@bigInx:
  1218. {       MOV     EDX,EAX
  1219.         JMP     @@cont1 }
  1220. @@smallCount:
  1221.         XOR     ECX,ECX
  1222.         JMP     @@cont2
  1223. @@bigCount:
  1224.         MOV     ECX,EAX
  1225.         JMP     @@cont2
  1226. @@srcEmpty:
  1227.         MOV     [EDI],AL
  1228. @@exit:
  1229.         POP     EDI
  1230.         POP     ESI
  1231.     RET 4
  1232. end;
  1233.  
  1234. procedure       _Delete{ var s : openstring; index, count : Integer };
  1235. asm
  1236. {     ->EAX     Pointer to s    }
  1237. {       EDX     index           }
  1238. {       ECX     count           }
  1239.  
  1240.         PUSH    ESI
  1241.         PUSH    EDI
  1242.  
  1243.         MOV     EDI,EAX
  1244.  
  1245.         XOR     EAX,EAX
  1246.         MOV     AL,[EDI]
  1247.  
  1248. {       if index not in [1 .. Length(s)] do nothing     }
  1249.  
  1250.         TEST    EDX,EDX
  1251.         JLE     @@exit
  1252.         CMP     EDX,EAX
  1253.         JG      @@exit
  1254.  
  1255. {       limit count to [0 .. Length(s) - index + 1]     }
  1256.  
  1257.         TEST    ECX,ECX
  1258.         JLE     @@exit
  1259.         SUB     EAX,EDX         { calculate Length(s) - index + 1       }
  1260.         INC     EAX
  1261.         CMP     ECX,EAX
  1262.         JLE     @@1
  1263.         MOV     ECX,EAX
  1264. @@1:
  1265.         SUB     [EDI],CL        { reduce Length(s) by count                     }
  1266.         ADD     EDI,EDX         { point EDI to first char to be deleted }
  1267.         LEA     ESI,[EDI+ECX]   { point ESI to first char to be preserved       }
  1268.         SUB     EAX,ECX         { #chars = Length(s) - index + 1 - count        }
  1269.         MOV     ECX,EAX
  1270.  
  1271.         REP     MOVSB
  1272.  
  1273. @@exit:
  1274.         POP     EDI
  1275.         POP     ESI
  1276. end;
  1277.  
  1278. procedure       __Flush( var f : Text );
  1279. external;       {   Assign  }
  1280.  
  1281. procedure       _Flush( var f : Text );
  1282. external;       {   Assign  }
  1283.  
  1284. procedure _LGetDir(D: Byte; var S: string);
  1285. var
  1286.   Drive: array[0..3] of Char;
  1287.   DirBuf, SaveBuf: array[0..259] of Char;
  1288. begin
  1289.   if D <> 0 then
  1290.   begin
  1291.         Drive[0] := Chr(D + Ord('A') - 1);
  1292.         Drive[1] := ':';
  1293.         Drive[2] := #0;
  1294.         GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf);
  1295.         SetCurrentDirectory(Drive);
  1296.   end;
  1297.   GetCurrentDirectory(SizeOf(DirBuf), DirBuf);
  1298.   if D <> 0 then SetCurrentDirectory(SaveBuf);
  1299.   S := DirBuf;
  1300. end;
  1301.  
  1302. procedure _SGetDir(D: Byte; var S: ShortString);
  1303. var
  1304.   L: string;
  1305. begin
  1306.   GetDir(D, L);
  1307.   S := L;
  1308. end;
  1309.  
  1310. procedure       _Insert{ source : ShortString; var s : openstring; index : Integer };
  1311. asm
  1312. {     ->EAX     Pointer to source string        }
  1313. {       EDX     Pointer to destination string   }
  1314. {       ECX     Length of destination string    }
  1315. {       [ESP+4] Index                   }
  1316.  
  1317.         PUSH    EBX
  1318.         PUSH    ESI
  1319.         PUSH    EDI
  1320.         PUSH    ECX
  1321.         MOV     ECX,[ESP+16+4]
  1322.         SUB     ESP,512         { VAR buf: ARRAY [0..511] of Char       }
  1323.  
  1324.         MOV     EBX,EDX         { save pointer to s for later   }
  1325.         MOV     ESI,EDX
  1326.  
  1327.         XOR     EDX,EDX
  1328.         MOV     DL,[ESI]
  1329.         INC     ESI
  1330.  
  1331. {       limit index to [1 .. Length(s)+1]       }
  1332.  
  1333.         INC     EDX
  1334.         TEST    ECX,ECX
  1335.         JLE     @@smallInx
  1336.         CMP     ECX,EDX
  1337.         JG      @@bigInx
  1338. @@cont1:
  1339.         DEC     EDX     { EDX = Length(s)               }
  1340.                         { EAX = Pointer to src  }
  1341.                         { ESI = EBX = Pointer to s      }
  1342.                         { ECX = Index           }
  1343.  
  1344. {       copy index-1 chars from s to buf        }
  1345.  
  1346.         MOV     EDI,ESP
  1347.         DEC     ECX
  1348.         SUB     EDX,ECX { EDX = remaining length of s   }
  1349.         REP     MOVSB
  1350.  
  1351. {       copy Length(src) chars from src to buf  }
  1352.  
  1353.         XCHG    EAX,ESI { save pointer into s, point ESI to src         }
  1354.         MOV     CL,[ESI]        { ECX = Length(src) (ECX was zero after rep)    }
  1355.         INC     ESI
  1356.         REP     MOVSB
  1357.  
  1358. {       copy remaining chars of s to buf        }
  1359.  
  1360.         MOV     ESI,EAX { restore pointer into s                }
  1361.         MOV     ECX,EDX { copy remaining bytes of s             }
  1362.         REP     MOVSB
  1363.  
  1364. {       calculate total chars in buf    }
  1365.  
  1366.         SUB     EDI,ESP         { length = bufPtr - buf         }
  1367.         MOV     ECX,[ESP+512]   { ECX = Min(length, destLength) }
  1368. {       MOV     ECX,[EBP-16]    { ECX = Min(length, destLength) }
  1369.         CMP     ECX,EDI
  1370.         JB      @@1
  1371.         MOV     ECX,EDI
  1372. @@1:
  1373.         MOV     EDI,EBX         { Point EDI to s                }
  1374.         MOV     ESI,ESP         { Point ESI to buf              }
  1375.         MOV     [EDI],CL        { Store length in s             }
  1376.         INC     EDI
  1377.         REP     MOVSB           { Copy length chars to s        }
  1378.         JMP     @@exit
  1379.  
  1380. @@smallInx:
  1381.         MOV     ECX,1
  1382.         JMP     @@cont1
  1383. @@bigInx:
  1384.         MOV     ECX,EDX
  1385.         JMP     @@cont1
  1386.  
  1387. @@exit:
  1388.         ADD     ESP,512+4
  1389.         POP     EDI
  1390.         POP     ESI
  1391.         POP     EBX
  1392.     RET 4
  1393. end;
  1394.  
  1395. function IOResult: Integer;
  1396. asm
  1397.         CALL    SysInit.@GetTLS
  1398.         XOR     EDX,EDX
  1399.         MOV     ECX,[EAX].InOutRes
  1400.         MOV     [EAX].InOutRes,EDX
  1401.         MOV     EAX,ECX
  1402. end;
  1403.  
  1404. procedure _MkDir(const S: string);
  1405. begin
  1406.   if not CreateDirectory(PChar(S), 0) then InOutError;
  1407. end;
  1408.  
  1409. procedure       Move( const Source; var Dest; count : Integer );
  1410. asm
  1411. {     ->EAX     Pointer to source       }
  1412. {       EDX     Pointer to destination  }
  1413. {       ECX     Count                   }
  1414.  
  1415.         PUSH    ESI
  1416.         PUSH    EDI
  1417.  
  1418.         MOV     ESI,EAX
  1419.         MOV     EDI,EDX
  1420.  
  1421.         MOV     EAX,ECX
  1422.  
  1423.         CMP     EDI,ESI
  1424.         JG      @@down
  1425.         JE      @@exit
  1426.  
  1427.         SAR     ECX,2           { copy count DIV 4 dwords       }
  1428.         JS      @@exit
  1429.  
  1430.         REP     MOVSD
  1431.  
  1432.         MOV     ECX,EAX
  1433.         AND     ECX,03H
  1434.         REP     MOVSB           { copy count MOD 4 bytes        }
  1435.         JMP     @@exit
  1436.  
  1437. @@down:
  1438.         LEA     ESI,[ESI+ECX-4] { point ESI to last dword of source     }
  1439.         LEA     EDI,[EDI+ECX-4] { point EDI to last dword of dest       }
  1440.  
  1441.         SAR     ECX,2           { copy count DIV 4 dwords       }
  1442.         JS      @@exit
  1443.         STD
  1444.         REP     MOVSD
  1445.  
  1446.         MOV     ECX,EAX
  1447.         AND     ECX,03H         { copy count MOD 4 bytes        }
  1448.         ADD     ESI,4-1         { point to last byte of rest    }
  1449.         ADD     EDI,4-1
  1450.         REP     MOVSB
  1451.         CLD
  1452. @@exit:
  1453.         POP     EDI
  1454.         POP     ESI
  1455. end;
  1456.  
  1457. function GetParamStr(P: PChar; var Param: string): PChar;
  1458. var
  1459.   Len: Integer;
  1460.   Buffer: array[Byte] of Char;
  1461. begin
  1462.   while True do
  1463.   begin
  1464.     while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
  1465.     if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
  1466.   end;
  1467.   Len := 0;
  1468.   while P[0] > ' ' do
  1469.     if P[0] = '"' then
  1470.     begin
  1471.       Inc(P);
  1472.       while (P[0] <> #0) and (P[0] <> '"') do
  1473.       begin
  1474.         Buffer[Len] := P[0];
  1475.         Inc(Len);
  1476.         Inc(P);
  1477.       end;
  1478.       if P[0] <> #0 then Inc(P);
  1479.     end else
  1480.     begin
  1481.       Buffer[Len] := P[0];
  1482.       Inc(Len);
  1483.       Inc(P);
  1484.     end;
  1485.   SetString(Param, Buffer, Len);
  1486.   Result := P;
  1487. end;
  1488.  
  1489. function ParamCount: Integer;
  1490. var
  1491.   P: PChar;
  1492.   S: string;
  1493. begin
  1494.   P := GetParamStr(GetCommandLine, S);
  1495.   Result := 0;
  1496.   while True do
  1497.   begin
  1498.     P := GetParamStr(P, S);
  1499.     if S = '' then Break;
  1500.     Inc(Result);
  1501.   end;
  1502. end;
  1503.  
  1504. function ParamStr(Index: Integer): string;
  1505. var
  1506.   P: PChar;
  1507.   Buffer: array[0..260] of Char;
  1508. begin
  1509.   if Index = 0 then
  1510.     SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer)))
  1511.   else
  1512.   begin
  1513.     P := GetCommandLine;
  1514.     while True do
  1515.     begin
  1516.       P := GetParamStr(P, Result);
  1517.       if (Index = 0) or (Result = '') then Break;
  1518.       Dec(Index);
  1519.     end;
  1520.   end;
  1521. end;
  1522.  
  1523. procedure       _Pos{ substr : ShortString; s : ShortString ) : Integer};
  1524. asm
  1525. {     ->EAX     Pointer to substr               }
  1526. {       EDX     Pointer to string               }
  1527. {     <-EAX     Position of substr in s or 0    }
  1528.  
  1529.         PUSH    EBX
  1530.         PUSH    ESI
  1531.         PUSH    EDI
  1532.  
  1533.         MOV     ESI,EAX { Point ESI to substr           }
  1534.         MOV     EDI,EDX { Point EDI to s                }
  1535.  
  1536.         XOR     ECX,ECX { ECX = Length(s)               }
  1537.         MOV     CL,[EDI]
  1538.         INC     EDI             { Point EDI to first char of s  }
  1539.  
  1540.         PUSH    EDI             { remember s position to calculate index        }
  1541.  
  1542.         XOR     EDX,EDX { EDX = Length(substr)          }
  1543.         MOV     DL,[ESI]
  1544.         INC     ESI             { Point ESI to first char of substr     }
  1545.  
  1546.         DEC     EDX             { EDX = Length(substr) - 1              }
  1547.         JS      @@fail  { < 0 ? return 0                        }
  1548.         MOV     AL,[ESI]        { AL = first char of substr             }
  1549.         INC     ESI             { Point ESI to 2'nd char of substr      }
  1550.  
  1551.         SUB     ECX,EDX { #positions in s to look at    }
  1552.                         { = Length(s) - Length(substr) + 1      }
  1553.         JLE     @@fail
  1554. @@loop:
  1555.         REPNE   SCASB
  1556.         JNE     @@fail
  1557.         MOV     EBX,ECX { save outer loop counter               }
  1558.         PUSH    ESI             { save outer loop substr pointer        }
  1559.         PUSH    EDI             { save outer loop s pointer             }
  1560.  
  1561.         MOV     ECX,EDX
  1562.         REPE    CMPSB
  1563.         POP     EDI             { restore outer loop s pointer  }
  1564.         POP     ESI             { restore outer loop substr pointer     }
  1565.         JE      @@found
  1566.         MOV     ECX,EBX { restore outer loop counter    }
  1567.         JMP     @@loop
  1568.  
  1569. @@fail:
  1570.         POP     EDX             { get rid of saved s pointer    }
  1571.         XOR     EAX,EAX
  1572.         JMP     @@exit
  1573.  
  1574. @@found:
  1575.         POP     EDX             { restore pointer to first char of s    }
  1576.         MOV     EAX,EDI { EDI points of char after match        }
  1577.         SUB     EAX,EDX { the difference is the correct index   }
  1578. @@exit:
  1579.         POP     EDI
  1580.         POP     ESI
  1581.         POP     EBX
  1582. end;
  1583.  
  1584. procedure       _SetLength{var s: ShortString; newLength: Integer};
  1585. asm
  1586.         { ->    EAX pointer to string   }
  1587.         {       EDX new length          }
  1588.  
  1589.         MOV     [EAX],DL        { should also fill new space, parameter should be openstring }
  1590.  
  1591. end;
  1592.  
  1593. procedure       _SetString{var s: ShortString: buffer: PChar; len: Integer};
  1594. asm
  1595.         { ->    EAX pointer to string           }
  1596.         {       EDX pointer to buffer   }
  1597.         {       ECX len                         }
  1598.  
  1599.         MOV     [EAX],CL
  1600.         TEST    EDX,EDX
  1601.         JE      @@noMove
  1602.         XCHG    EAX,EDX
  1603.         INC     EDX
  1604.         CALL    Move
  1605. @@noMove:
  1606. end;
  1607.  
  1608. procedure       Randomize;
  1609. var
  1610.         systemTime :
  1611.         record
  1612.                 wYear   : Word;
  1613.                 wMonth  : Word;
  1614.                 wDayOfWeek      : Word;
  1615.                 wDay    : Word;
  1616.                 wHour   : Word;
  1617.                 wMinute : Word;
  1618.                 wSecond : Word;
  1619.                 wMilliSeconds: Word;
  1620.                 reserved        : array [0..7] of char;
  1621.         end;
  1622. asm
  1623.         LEA     EAX,systemTime
  1624.         PUSH    EAX
  1625.         CALL    GetSystemTime
  1626.         MOVZX   EAX,systemTime.wHour
  1627.         IMUL    EAX,60
  1628.         ADD     AX,systemTime.wMinute   { sum = hours * 60 + minutes    }
  1629.         IMUL    EAX,60
  1630.         XOR     EDX,EDX
  1631.         MOV     DX,systemTime.wSecond
  1632.         ADD     EAX,EDX                 { sum = sum * 60 + seconds              }
  1633.         IMUL    EAX,1000
  1634.         MOV     DX,systemTime.wMilliSeconds
  1635.         ADD     EAX,EDX                 { sum = sum * 1000 + milliseconds       }
  1636.         MOV     RandSeed,EAX
  1637. end;
  1638.  
  1639. procedure _RmDir(const S: string);
  1640. begin
  1641.   if not RemoveDirectory(PChar(S)) then InOutError;
  1642. end;
  1643.  
  1644. function        UpCase( ch : Char ) : Char;
  1645. asm
  1646. { ->    AL      Character       }
  1647. { <-    AL      Result          }
  1648.  
  1649.         CMP     AL,'a'
  1650.         JB      @@exit
  1651.         CMP     AL,'z'
  1652.         JA      @@exit
  1653.         SUB     AL,'a' - 'A'
  1654. @@exit:
  1655. end;
  1656.  
  1657. { ----------------------------------------------------- }
  1658. {       functions & procedures that need compiler magic }
  1659. { ----------------------------------------------------- }
  1660.  
  1661. const cwChop : Word = $1F32;
  1662.  
  1663. procedure       _COS;
  1664. asm
  1665.         FCOS
  1666.         FNSTSW  AX
  1667.         SAHF
  1668.         JP      @@outOfRange
  1669.         RET
  1670. @@outOfRange:
  1671.         FSTP    st(0)   { for now, return 0. result would }
  1672.         FLDZ            { have little significance anyway }
  1673. end;
  1674.  
  1675. procedure       _EXP;
  1676. asm
  1677.         {       e**x = 2**(x*log2(e))   }
  1678.  
  1679.         FLDL2E              { y := x*log2e;      }
  1680.         FMUL
  1681.         FLD     ST(0)       { i := round(y);     }
  1682.         FRNDINT
  1683.         FSUB    ST(1), ST   { f := y - i;        }
  1684.         FXCH    ST(1)       { z := 2**f          }
  1685.         F2XM1
  1686.         FLD1
  1687.         FADD
  1688.         FSCALE              { result := z * 2**i }
  1689.         FSTP    ST(1)
  1690. end;
  1691.  
  1692. procedure       _INT;
  1693. asm
  1694.         SUB     ESP,4
  1695.         FSTCW   [ESP]
  1696.         FWAIT
  1697.         FLDCW   cwChop
  1698.         FRNDINT
  1699.         FWAIT
  1700.         FLDCW   [ESP]
  1701.         ADD     ESP,4
  1702. end;
  1703.  
  1704. procedure       _SIN;
  1705. asm
  1706.         FSIN
  1707.         FNSTSW  AX
  1708.         SAHF
  1709.         JP      @@outOfRange
  1710.         RET
  1711. @@outOfRange:
  1712.         FSTP    st(0)   { for now, return 0. result would       }
  1713.         FLDZ            { have little significance anyway       }
  1714. end;
  1715.  
  1716. procedure       _FRAC;
  1717. asm
  1718.         FLD     ST(0)
  1719.         SUB     ESP,4
  1720.         FSTCW   [ESP]
  1721.         FWAIT
  1722.         FLDCW   cwChop
  1723.         FRNDINT
  1724.         FWAIT
  1725.         FLDCW   [ESP]
  1726.         ADD     ESP,4
  1727.         FSUB
  1728. end;
  1729.  
  1730. procedure       _ROUND;
  1731. asm
  1732. { ->    FST(0)  Extended argument       }
  1733. { <-    EAX     Result                  }
  1734.  
  1735.         PUSH    EAX
  1736.         FISTP   dword ptr [ESP]
  1737.         FWAIT
  1738.         POP     EAX
  1739. end;
  1740.  
  1741. procedure       _TRUNC;
  1742. asm
  1743.         { ->    FST(0)  Extended argument       }
  1744.         { <-    EAX     Result                  }
  1745.  
  1746.         SUB     ESP,8
  1747.         FSTCW   [ESP]
  1748.         FWAIT
  1749.         FLDCW   cwChop
  1750.         FISTP   dword ptr [ESP+4]
  1751.         FWAIT
  1752.         FLDCW   [ESP]
  1753.         ADD     ESP,4
  1754.         POP     EAX
  1755. end;
  1756.  
  1757. procedure       _AbstractError;
  1758. asm
  1759.         MOV     EAX,210
  1760.         JMP     _RunError
  1761. end;
  1762.  
  1763. procedure       _Append;                                external;       {   OpenText}
  1764. procedure       _Assign(var t: text; s: ShortString);   external;       {$L Assign  }
  1765. procedure       _BlockRead;                             external;       {$L BlockRea}
  1766. procedure       _BlockWrite;                            external;       {$L BlockWri}
  1767. procedure       _Close;                                 external;       {$L Close   }
  1768.  
  1769. procedure       _PStrCat;
  1770. asm
  1771. {     ->EAX = Pointer to destination string     }
  1772. {       EDX = Pointer to source string  }
  1773.  
  1774.         PUSH    ESI
  1775.         PUSH    EDI
  1776.  
  1777. {       load dest len into EAX  }
  1778.  
  1779.         MOV     EDI,EAX
  1780.         XOR     EAX,EAX
  1781.         MOV     AL,[EDI]
  1782.  
  1783. {       load source address in ESI, source len in ECX   }
  1784.  
  1785.         MOV     ESI,EDX
  1786.         XOR     ECX,ECX
  1787.         MOV     CL,[ESI]
  1788.         INC     ESI
  1789.  
  1790. {       calculate final length in DL and store it in the destination    }
  1791.  
  1792.         MOV     DL,AL
  1793.         ADD     DL,CL
  1794.         JC      @@trunc
  1795.  
  1796. @@cont:
  1797.         MOV     [EDI],DL
  1798.  
  1799. {       calculate final dest address    }
  1800.  
  1801.         INC     EDI
  1802.         ADD     EDI,EAX
  1803.  
  1804. {       do the copy     }
  1805.  
  1806.         REP     MOVSB
  1807.  
  1808. {       done    }
  1809.  
  1810.         POP     EDI
  1811.         POP     ESI
  1812.         RET
  1813.  
  1814. @@trunc:
  1815.         INC     DL      {       DL = #chars to truncate                 }
  1816.         SUB     CL,DL   {       CL = source len - #chars to truncate    }
  1817.         MOV     DL,255  {       DL = maximum length                     }
  1818.         JMP     @@cont
  1819. end;
  1820.  
  1821. procedure       _PStrNCat;
  1822. asm
  1823. {     ->EAX = Pointer to destination string                     }
  1824. {       EDX = Pointer to source string                          }
  1825. {       CL  = max length of result (allocated size of dest - 1) }
  1826.  
  1827.         PUSH    ESI
  1828.         PUSH    EDI
  1829.  
  1830. {       load dest len into EAX  }
  1831.  
  1832.         MOV     EDI,EAX
  1833.         XOR     EAX,EAX
  1834.         MOV     AL,[EDI]
  1835.  
  1836. {       load source address in ESI, source len in EDX   }
  1837.  
  1838.         MOV     ESI,EDX
  1839.         XOR     EDX,EDX
  1840.         MOV     DL,[ESI]
  1841.         INC     ESI
  1842.  
  1843. {       calculate final length in AL and store it in the destination    }
  1844.  
  1845.         ADD     AL,DL
  1846.         JC      @@trunc
  1847.         CMP     AL,CL
  1848.         JA      @@trunc
  1849.  
  1850. @@cont:
  1851.         MOV     ECX,EDX
  1852.         MOV     DL,[EDI]
  1853.         MOV     [EDI],AL
  1854.  
  1855. {       calculate final dest address    }
  1856.  
  1857.         INC     EDI
  1858.         ADD     EDI,EDX
  1859.  
  1860. {       do the copy     }
  1861.  
  1862.         REP     MOVSB
  1863.  
  1864. @@done:
  1865.         POP     EDI
  1866.         POP     ESI
  1867.         RET
  1868.  
  1869. @@trunc:
  1870. {       CL = maxlen     }
  1871.  
  1872.         MOV     AL,CL   { AL = final length = maxlen            }
  1873.         SUB     CL,[EDI]        { CL = length to copy = maxlen - destlen        }
  1874.         JBE     @@done
  1875.         MOV     DL,CL
  1876.         JMP     @@cont
  1877. end;
  1878.  
  1879. procedure       _PStrCpy;
  1880. asm
  1881. {     ->EAX = Pointer to dest string    }
  1882. {       EDX = Pointer to source string  }
  1883.  
  1884.         XOR     ECX,ECX
  1885.  
  1886.         PUSH    ESI
  1887.         PUSH    EDI
  1888.  
  1889.         MOV     CL,[EDX]
  1890.  
  1891.         MOV     EDI,EAX
  1892.  
  1893.         INC     ECX             { we must copy len+1 bytes      }
  1894.  
  1895.         MOV     ESI,EDX
  1896.  
  1897.         MOV     EAX,ECX
  1898.         SHR     ECX,2
  1899.         AND     EAX,3
  1900.         REP     MOVSD
  1901.  
  1902.         MOV     ECX,EAX
  1903.         REP     MOVSB
  1904.  
  1905.         POP     EDI
  1906.         POP     ESI
  1907. end;
  1908.  
  1909. procedure       _PStrNCpy;
  1910. asm
  1911. {     ->EAX = Pointer to dest string                            }
  1912. {       EDX = Pointer to source string                          }
  1913. {       CL  = Maximum length to copy (allocated size of dest - 1)       }
  1914.  
  1915.         PUSH    ESI
  1916.         PUSH    EDI
  1917.  
  1918.         MOV     EDI,EAX
  1919.         XOR     EAX,EAX
  1920.         MOV     ESI,EDX
  1921.  
  1922.         MOV     AL,[EDX]
  1923.         CMP     AL,CL
  1924.         JA      @@trunc
  1925.  
  1926.         INC     EAX
  1927.  
  1928.         MOV     ECX,EAX
  1929.         AND     EAX,3
  1930.         SHR     ECX,2
  1931.         REP     MOVSD
  1932.  
  1933.         MOV     ECX,EAX
  1934.         REP     MOVSB
  1935.  
  1936.         POP     EDI
  1937.         POP     ESI
  1938.         RET
  1939.  
  1940. @@trunc:
  1941.         MOV     [EDI],CL        { result length is maxLen       }
  1942.         INC     ESI             { advance pointers              }
  1943.         INC     EDI
  1944.         AND     ECX,0FFH        { should be cheaper than MOVZX  }
  1945.         REP     MOVSB   { copy maxLen bytes             }
  1946.  
  1947.         POP     EDI
  1948.         POP     ESI
  1949. end;
  1950.  
  1951. procedure       _PStrCmp;
  1952. asm
  1953. {     ->EAX = Pointer to left string    }
  1954. {       EDX = Pointer to right string   }
  1955.  
  1956.         PUSH    EBX
  1957.         PUSH    ESI
  1958.         PUSH    EDI
  1959.  
  1960.         MOV     ESI,EAX
  1961.         MOV     EDI,EDX
  1962.  
  1963.         XOR     EAX,EAX
  1964.         XOR     EDX,EDX
  1965.         MOV     AL,[ESI]
  1966.         MOV     DL,[EDI]
  1967.         INC     ESI
  1968.         INC     EDI
  1969.  
  1970.         SUB     EAX,EDX { eax = len1 - len2 }
  1971.         JA      @@skip1
  1972.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  1973.  
  1974. @@skip1:
  1975.         PUSH    EDX
  1976.         SHR     EDX,2
  1977.         JE      @@cmpRest
  1978. @@longLoop:
  1979.         MOV     ECX,[ESI]
  1980.         MOV     EBX,[EDI]
  1981.         CMP     ECX,EBX
  1982.         JNE     @@misMatch
  1983.         DEC     EDX
  1984.         JE      @@cmpRestP4
  1985.         MOV     ECX,[ESI+4]
  1986.         MOV     EBX,[EDI+4]
  1987.         CMP     ECX,EBX
  1988.         JNE     @@misMatch
  1989.         ADD     ESI,8
  1990.         ADD     EDI,8
  1991.         DEC     EDX
  1992.         JNE     @@longLoop
  1993.         JMP     @@cmpRest
  1994. @@cmpRestP4:
  1995.         ADD     ESI,4
  1996.         ADD     EDI,4
  1997. @@cmpRest:
  1998.         POP     EDX
  1999.         AND     EDX,3
  2000.         JE      @@equal
  2001.  
  2002.         MOV     CL,[ESI]
  2003.         CMP     CL,[EDI]
  2004.         JNE     @@exit
  2005.         DEC     EDX
  2006.         JE      @@equal
  2007.         MOV     CL,[ESI+1]
  2008.         CMP     CL,[EDI+1]
  2009.         JNE     @@exit
  2010.         DEC     EDX
  2011.         JE      @@equal
  2012.         MOV     CL,[ESI+2]
  2013.         CMP     CL,[EDI+2]
  2014.         JNE     @@exit
  2015.  
  2016. @@equal:
  2017.         ADD     EAX,EAX
  2018.         JMP     @@exit
  2019.  
  2020. @@misMatch:
  2021.         POP     EDX
  2022.         CMP     CL,BL
  2023.         JNE     @@exit
  2024.         CMP     CH,BH
  2025.         JNE     @@exit
  2026.         SHR     ECX,16
  2027.         SHR     EBX,16
  2028.         CMP     CL,BL
  2029.         JNE     @@exit
  2030.         CMP     CH,BH
  2031.  
  2032. @@exit:
  2033.         POP     EDI
  2034.         POP     ESI
  2035.         POP     EBX
  2036. end;
  2037.  
  2038. procedure       _AStrCmp;
  2039. asm
  2040. {     ->EAX = Pointer to left string    }
  2041. {       EDX = Pointer to right string   }
  2042. {       ECX = Number of chars to compare}
  2043.  
  2044.         PUSH    EBX
  2045.         PUSH    ESI
  2046.         PUSH    ECX
  2047.         MOV     ESI,ECX
  2048.         SHR     ESI,2
  2049.         JE      @@cmpRest
  2050.  
  2051. @@longLoop:
  2052.         MOV     ECX,[EAX]
  2053.         MOV     EBX,[EDX]
  2054.         CMP     ECX,EBX
  2055.         JNE     @@misMatch
  2056.         DEC     ESI
  2057.         JE      @@cmpRestP4
  2058.         MOV     ECX,[EAX+4]
  2059.         MOV     EBX,[EDX+4]
  2060.         CMP     ECX,EBX
  2061.         JNE     @@misMatch
  2062.         ADD     EAX,8
  2063.         ADD     EDX,8
  2064.         DEC     ESI
  2065.         JNE     @@longLoop
  2066.         JMP     @@cmpRest
  2067. @@cmpRestp4:
  2068.         ADD     EAX,4
  2069.         ADD     EDX,4
  2070. @@cmpRest:
  2071.         POP     ESI
  2072.         AND     ESI,3
  2073.         JE      @@exit
  2074.  
  2075.         MOV     CL,[EAX]
  2076.         CMP     CL,[EDX]
  2077.         JNE     @@exit
  2078.         DEC     ESI
  2079.         JE      @@equal
  2080.         MOV     CL,[EAX+1]
  2081.         CMP     CL,[EDX+1]
  2082.         JNE     @@exit
  2083.         DEC     ESI
  2084.         JE      @@equal
  2085.         MOV     CL,[EAX+2]
  2086.         CMP     CL,[EDX+2]
  2087.         JNE     @@exit
  2088.  
  2089. @@equal:
  2090.         XOR     EAX,EAX
  2091.         JMP     @@exit
  2092.  
  2093. @@misMatch:
  2094.         POP     ESI
  2095.         CMP     CL,BL
  2096.         JNE     @@exit
  2097.         CMP     CH,BH
  2098.         JNE     @@exit
  2099.         SHR     ECX,16
  2100.         SHR     EBX,16
  2101.         CMP     CL,BL
  2102.         JNE     @@exit
  2103.         CMP     CH,BH
  2104.  
  2105. @@exit:
  2106.         POP     ESI
  2107.         POP     EBX
  2108. end;
  2109.  
  2110. procedure       _EofFile;                               external;       {$L EofFile }
  2111. procedure       _EofText;                               external;       {$L EofText }
  2112. procedure       _Eoln;                          external;       {$L Eoln    }
  2113. procedure       _Erase;                         external;       {$L Erase   }
  2114.  
  2115. procedure       _FSafeDivide;                           external;       {$L FDIV    }
  2116. procedure       _FSafeDivideR;                          external;       {   FDIV    }
  2117.  
  2118. procedure       _FilePos;                               external;       {$L FilePos }
  2119. procedure       _FileSize;                              external;       {$L FileSize}
  2120.  
  2121. procedure       _FillChar;
  2122. asm
  2123. {     ->EAX     Pointer to destination  }
  2124. {       EDX     count   }
  2125. {       CL      value   }
  2126.  
  2127.         PUSH    EDI
  2128.  
  2129.         MOV     EDI,EAX { Point EDI to destination              }
  2130.  
  2131.         MOV     CH,CL   { Fill EAX with value repeated 4 times  }
  2132.         MOV     EAX,ECX
  2133.         SHL     EAX,16
  2134.         MOV     AX,CX
  2135.  
  2136.         MOV     ECX,EDX
  2137.         SAR     ECX,2
  2138.         JS      @@exit
  2139.  
  2140.         REP     STOSD   { Fill count DIV 4 dwords       }
  2141.  
  2142.         MOV     ECX,EDX
  2143.         AND     ECX,3
  2144.         REP     STOSB   { Fill count MOD 4 bytes        }
  2145.  
  2146. @@exit:
  2147.         POP     EDI
  2148. end;
  2149.  
  2150. procedure       _Mark;
  2151. begin
  2152.   Error(reInvalidPtr);
  2153. end;
  2154.  
  2155. procedure       _RandInt;
  2156. asm
  2157. {     ->EAX     Range   }
  2158. {     <-EAX     Result  }
  2159.         IMUL    EDX,RandSeed,08088405H
  2160.         INC     EDX
  2161.         MOV     RandSeed,EDX
  2162.         MUL     EDX
  2163.         MOV     EAX,EDX
  2164. end;
  2165.  
  2166. procedure       _RandExt;
  2167. const   Minus32: double = -32.0;
  2168. asm
  2169. {       FUNCTION _RandExt: Extended;    }
  2170. {     ->EAX     Range   }
  2171.  
  2172.         IMUL    EDX,RandSeed,08088405H
  2173.         INC     EDX
  2174.         MOV     RandSeed,EDX
  2175.  
  2176.         FLD     Minus32
  2177.         PUSH    0
  2178.         PUSH    EDX
  2179.         FILD    qword ptr [ESP]
  2180.         ADD     ESP,8
  2181.         FSCALE
  2182.         FSTP    ST(1)
  2183. end;
  2184.  
  2185. procedure       _ReadRec;                               external;       {$L ReadRec }
  2186.  
  2187. procedure       _ReadChar;                              external;       {$L ReadChar}
  2188. procedure       _ReadLong;                              external;       {$L ReadLong}
  2189. procedure       _ReadString;                    external;       {$L ReadStri}
  2190. procedure       _ReadCString;                   external;       {   ReadStri}
  2191.  
  2192. procedure       _ReadExt;                               external;       {$L ReadExt }
  2193. procedure       _ReadLn;                                external;       {$L ReadLn  }
  2194.  
  2195. procedure       _Rename;                                external;       {$L Rename  }
  2196.  
  2197. procedure       _Release;
  2198. begin
  2199.   Error(reInvalidPtr);
  2200. end;
  2201.  
  2202. procedure       _ResetText(var t: text);                external;       {$L OpenText}
  2203. procedure       _ResetFile;                             external;       {$L OpenFile}
  2204. procedure       _RewritText(var t: text);               external;       {   OpenText}
  2205. procedure       _RewritFile;                    external;       {   OpenFile}
  2206.  
  2207. procedure       _Seek;                          external;       {$L Seek    }
  2208. procedure       _SeekEof;                               external;       {$L SeekEof }
  2209. procedure       _SeekEoln;                              external;       {$L SeekEoln}
  2210.  
  2211. procedure       _SetTextBuf;                    external;       {$L SetTextB}
  2212.  
  2213. procedure       _StrLong;
  2214. asm
  2215. {       PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString );
  2216.       ->EAX     Value
  2217.         EDX     Width
  2218.         ECX     Pointer to string       }
  2219.  
  2220.         PUSH    EBX             { VAR i: Longint;               }
  2221.         PUSH    ESI             { VAR sign : Longint;           }
  2222.         PUSH    EDI
  2223.         PUSH    EDX             { store width on the stack      }
  2224.         SUB     ESP,20          { VAR a: array [0..19] of Char; }
  2225.  
  2226.         MOV     EDI,ECX
  2227.  
  2228.         MOV     ESI,EAX         { sign := val                   }
  2229.  
  2230.         CDQ                     { val := Abs(val);  canned sequence }
  2231.         XOR     EAX,EDX
  2232.         SUB     EAX,EDX
  2233.  
  2234.         MOV     ECX,10
  2235.         XOR     EBX,EBX         { i := 0;                       }
  2236.  
  2237. @@repeat1:                      { repeat                        }
  2238.         XOR     EDX,EDX         {   a[i] := Chr( val MOD 10 + Ord('0') );}
  2239.  
  2240.         DIV     ECX             {   val := val DIV 10;          }
  2241.  
  2242.         ADD     EDX,'0'
  2243.         MOV     [ESP+EBX],DL
  2244.         INC     EBX             {   i := i + 1;                 }
  2245.         TEST    EAX,EAX         { until val = 0;                }
  2246.         JNZ     @@repeat1
  2247.  
  2248.         TEST    ESI,ESI
  2249.         JGE     @@2
  2250.         MOV     byte ptr [ESP+EBX],'-'
  2251.         INC     EBX
  2252. @@2:
  2253.         MOV     [EDI],BL        { s^++ := Chr(i);               }
  2254.         INC     EDI
  2255.  
  2256.         MOV     ECX,[ESP+20]    { spaceCnt := width - i;        }
  2257.         CMP     ECX,255
  2258.         JLE     @@3
  2259.         MOV     ECX,255
  2260. @@3:
  2261.         SUB     ECX,EBX
  2262.         JLE     @@repeat2       { for k := 1 to spaceCnt do s^++ := ' ';        }
  2263.         ADD     [EDI-1],CL
  2264.         MOV     AL,' '
  2265.         REP     STOSB
  2266.  
  2267. @@repeat2:                      { repeat                        }
  2268.         MOV     AL,[ESP+EBX-1]  {   s^ := a[i-1];               }
  2269.         MOV     [EDI],AL
  2270.         INC     EDI             {   s := s + 1                  }
  2271.         DEC     EBX             {   i := i - 1;                 }
  2272.         JNZ     @@repeat2       { until i = 0;                  }
  2273.  
  2274.         ADD     ESP,20+4
  2275.         POP     EDI
  2276.         POP     ESI
  2277.         POP     EBX
  2278. end;
  2279.  
  2280. procedure       _Str0Long;
  2281. asm
  2282. {     ->EAX     Value           }
  2283. {       EDX     Pointer to string       }
  2284.  
  2285.         MOV     ECX,EDX
  2286.         XOR     EDX,EDX
  2287.         JMP     _StrLong
  2288. end;
  2289.  
  2290. procedure       _Truncate;                              external;       {$L Truncate}
  2291.  
  2292. procedure       _ValLong;
  2293. asm
  2294. {       FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint;        }
  2295. {     ->EAX     Pointer to string       }
  2296. {       EDX     Pointer to code result  }
  2297. {     <-EAX     Result                  }
  2298.  
  2299.         PUSH    EBX
  2300.         PUSH    ESI
  2301.         PUSH    EDI
  2302.  
  2303.         MOV     ESI,EAX
  2304.         PUSH    EAX             { save for the error case       }
  2305.  
  2306.         TEST    EAX,EAX
  2307.         JE      @@empty
  2308.  
  2309.         XOR     EAX,EAX
  2310.         XOR     EBX,EBX
  2311.         MOV     EDI,07FFFFFFFH / 10     { limit }
  2312.  
  2313. @@blankLoop:
  2314.         MOV     BL,[ESI]
  2315.         INC     ESI
  2316.         CMP     BL,' '
  2317.         JE      @@blankLoop
  2318.  
  2319. @@endBlanks:
  2320.         MOV     CH,0
  2321.         CMP     BL,'-'
  2322.         JE      @@minus
  2323.         CMP     BL,'+'
  2324.         JE      @@plus
  2325.         CMP     BL,'$'
  2326.         JE      @@dollar
  2327.  
  2328. @@firstDigit:
  2329.         TEST    BL,BL
  2330.         JE      @@error
  2331.  
  2332. @@digLoop:
  2333.         SUB     BL,'0'
  2334.         CMP     BL,9
  2335.         JA      @@error
  2336.         CMP     EAX,EDI         { value > limit ?       }
  2337.         JA      @@overFlow
  2338.         LEA     EAX,[EAX+EAX*4]
  2339.         ADD     EAX,EAX
  2340.         ADD     EAX,EBX         { fortunately, we can't have a carry    }
  2341.  
  2342.         MOV     BL,[ESI]
  2343.         INC     ESI
  2344.  
  2345.         TEST    BL,BL
  2346.         JNE     @@digLoop
  2347.  
  2348. @@endDigits:
  2349.         DEC     CH
  2350.         JE      @@negate
  2351.         TEST    EAX,EAX
  2352.         JL      @@overFlow
  2353.  
  2354. @@successExit:
  2355.  
  2356.         POP     ECX                     { saved copy of string pointer  }
  2357.  
  2358.         XOR     ESI,ESI         { signal no error to caller     }
  2359.  
  2360. @@exit:
  2361.         MOV     [EDX],ESI
  2362.  
  2363.         POP     EDI
  2364.         POP     ESI
  2365.         POP     EBX
  2366.         RET
  2367.  
  2368. @@empty:
  2369.         INC     ESI
  2370.         JMP     @@error
  2371.  
  2372. @@negate:
  2373.         NEG     EAX
  2374.         JLE     @@successExit
  2375.  
  2376. @@error:
  2377. @@overFlow:
  2378.         POP     EBX
  2379.         SUB     ESI,EBX
  2380.         JMP     @@exit
  2381.  
  2382. @@minus:
  2383.         INC     CH
  2384. @@plus:
  2385.         MOV     BL,[ESI]
  2386.         INC     ESI
  2387.         JMP     @@firstDigit
  2388.  
  2389. @@dollar:
  2390.         MOV     EDI,0FFFFFFFH
  2391.  
  2392.         MOV     BL,[ESI]
  2393.         INC     ESI
  2394.         TEST    BL,BL
  2395.         JZ      @@empty
  2396.  
  2397. @@hDigLoop:
  2398.         CMP     BL,'a'
  2399.         JB      @@upper
  2400.         SUB     BL,'a' - 'A'
  2401. @@upper:
  2402.         SUB     BL,'0'
  2403.         CMP     BL,9
  2404.         JBE     @@digOk
  2405.         SUB     BL,'A' - '0'
  2406.         CMP     BL,5
  2407.         JA      @@error
  2408.         ADD     BL,10
  2409. @@digOk:
  2410.         CMP     EAX,EDI
  2411.         JA      @@overFlow
  2412.         SHL     EAX,4
  2413.         ADD     EAX,EBX
  2414.  
  2415.         MOV     BL,[ESI]
  2416.         INC     ESI
  2417.  
  2418.         TEST    BL,BL
  2419.         JNE     @@hDigLoop
  2420.  
  2421.         JMP     @@successExit
  2422. end;
  2423.  
  2424. procedure       _WriteRec;                              external;       {$L WriteRec}
  2425.  
  2426. procedure       _WriteChar;                             external;       {   WriteStr}
  2427. procedure       _Write0Char;                    external;       {   WriteStr}
  2428.  
  2429. procedure       _WriteBool;
  2430. asm
  2431. {       PROCEDURE _WriteBool( VAR t: Text; val: Boolean; width: Longint);       }
  2432. {     ->EAX     Pointer to file record  }
  2433. {       DL      Boolean value           }
  2434. {       ECX     Field width             }
  2435.  
  2436.         TEST    DL,DL
  2437.         JE      @@false
  2438.         MOV     EDX,offset @trueString
  2439.         JMP     _WriteString
  2440. @@false:
  2441.         MOV     EDX,offset @falseString
  2442.         JMP     _WriteString
  2443. @trueString:  db        4,'TRUE'
  2444. @falseString: db        5,'FALSE'
  2445. end;
  2446.  
  2447. procedure       _Write0Bool;
  2448. asm
  2449. {       PROCEDURE _Write0Bool( VAR t: Text; val: Boolean);      }
  2450. {     ->EAX     Pointer to file record  }
  2451. {       DL      Boolean value           }
  2452.  
  2453.         XOR     ECX,ECX
  2454.         JMP     _WriteBool
  2455. end;
  2456.  
  2457. procedure       _WriteLong;
  2458. asm
  2459. {       PROCEDURE _WriteLong( VAR t: Text; val: Longint; with: Longint);        }
  2460. {     ->EAX     Pointer to file record  }
  2461. {       EDX     Value                   }
  2462. {       ECX     Field width             }
  2463.  
  2464.         SUB     ESP,32          { VAR s: String[31];    }
  2465.  
  2466.         PUSH    EAX
  2467.         PUSH    ECX
  2468.  
  2469.         MOV     EAX,EDX         { Str( val : 0, s );    }
  2470.         XOR     EDX,EDX
  2471.         CMP     ECX,31
  2472.         JG      @@1
  2473.         MOV     EDX,ECX
  2474. @@1:
  2475.         LEA     ECX,[ESP+8]
  2476.         CALL    _StrLong
  2477.  
  2478.         POP     ECX
  2479.         POP     EAX
  2480.  
  2481.         MOV     EDX,ESP         { Write( t, s : width );}
  2482.         CALL    _WriteString
  2483.  
  2484.         ADD     ESP,32
  2485. end;
  2486.  
  2487. procedure       _Write0Long;
  2488. asm
  2489. {       PROCEDURE _Write0Long( VAR t: Text; val: Longint);      }
  2490. {     ->EAX     Pointer to file record  }
  2491. {       EDX     Value                   }
  2492.         XOR     ECX,ECX
  2493.         JMP     _WriteLong
  2494. end;
  2495.  
  2496. procedure       _WriteString;                   external;       {$L WriteStr}
  2497. procedure       _Write0String;                  external;       {   WriteStr}
  2498.  
  2499. procedure       _WriteCString;                  external;       {   WriteStr}
  2500. procedure       _Write0CString;                 external;       {   WriteStr}
  2501.  
  2502. procedure       _WriteBytes;                    external;       {   WriteStr}
  2503. procedure       _WriteSpaces;                   external;       {   WriteStr}
  2504.  
  2505. procedure       _Write2Ext;
  2506. asm
  2507. {       PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint);
  2508.       ->EAX     Pointer to file record
  2509.         [ESP+4] Extended value
  2510.         EDX     Field width
  2511.         ECX     precision (<0: scientific, >= 0: fixed point)   }
  2512.  
  2513.         FLD     tbyte ptr [ESP+4]       { load value    }
  2514.         SUB     ESP,256         { VAR s: String;        }
  2515.  
  2516.         PUSH    EAX
  2517.         PUSH    EDX
  2518.  
  2519. {       Str( val, width, prec, s );     }
  2520.  
  2521.         SUB     ESP,12
  2522.         FSTP    tbyte ptr [ESP] { pass value            }
  2523.         MOV     EAX,EDX         { pass field width              }
  2524.         MOV     EDX,ECX         { pass precision                }
  2525.         LEA     ECX,[ESP+8+12]  { pass destination string       }
  2526.         CALL    _Str2Ext
  2527.  
  2528. {       Write( t, s, width );   }
  2529.  
  2530.         POP     ECX                     { pass width    }
  2531.         POP     EAX                     { pass text     }
  2532.         MOV     EDX,ESP         { pass string   }
  2533.         CALL    _WriteString
  2534.  
  2535.         ADD     ESP,256
  2536.         RET     12
  2537. end;
  2538.  
  2539. procedure       _Write1Ext;
  2540. asm
  2541. {       PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint);
  2542.   ->    EAX     Pointer to file record
  2543.         [ESP+4] Extended value
  2544.         EDX     Field width             }
  2545.  
  2546.         OR      ECX,-1
  2547.         JMP     _Write2Ext
  2548. end;
  2549.  
  2550. procedure       _Write0Ext;
  2551. asm
  2552. {       PROCEDURE _Write0Ext( VAR t: Text; val: Extended);
  2553.       ->EAX     Pointer to file record
  2554.         [ESP+4] Extended value  }
  2555.  
  2556.         MOV     EDX,23  { field width   }
  2557.         OR      ECX,-1
  2558.         JMP     _Write2Ext
  2559. end;
  2560.  
  2561. procedure       _WriteLn;                       external;       {   WriteStr}
  2562.  
  2563. procedure       __CToPasStr;
  2564. asm
  2565. {     ->EAX     Pointer to destination  }
  2566. {       EDX     Pointer to source       }
  2567.  
  2568.         PUSH    EAX             { save destination      }
  2569.  
  2570.         MOV     CL,255
  2571. @@loop:
  2572.         MOV     CH,[EDX]        { ch = *src++;          }
  2573.         INC     EDX
  2574.         TEST    CH,CH   { if (ch == 0) break    }
  2575.         JE      @@endLoop
  2576.         INC     EAX             { *++dest = ch;         }
  2577.         MOV     [EAX],CH
  2578.         DEC     CL
  2579.         JNE     @@loop
  2580.  
  2581. @@endLoop:
  2582.         POP     EDX
  2583.         SUB     EAX,EDX
  2584.         MOV     [EDX],AL
  2585. end;
  2586.  
  2587. procedure       __CLenToPasStr;
  2588. asm
  2589. {     ->EAX     Pointer to destination  }
  2590. {       EDX     Pointer to source       }
  2591. {       ECX     cnt                     }
  2592.  
  2593.         PUSH    EBX
  2594.         PUSH    EAX             { save destination      }
  2595.  
  2596.         CMP     ECX,255
  2597.         JBE     @@loop
  2598.     MOV ECX,255
  2599. @@loop:
  2600.         MOV     BL,[EDX]        { ch = *src++;          }
  2601.         INC     EDX
  2602.         TEST    BL,BL   { if (ch == 0) break    }
  2603.         JE      @@endLoop
  2604.         INC     EAX             { *++dest = ch;         }
  2605.         MOV     [EAX],BL
  2606.         DEC     ECX             { while (--cnt != 0)    }
  2607.         JNZ     @@loop
  2608.  
  2609. @@endLoop:
  2610.         POP     EDX
  2611.         SUB     EAX,EDX
  2612.         MOV     [EDX],AL
  2613.         POP     EBX
  2614. end;
  2615.  
  2616. procedure       __ArrayToPasStr;
  2617. asm
  2618. {     ->EAX     Pointer to destination  }
  2619. {       EDX     Pointer to source       }
  2620. {       ECX     cnt                     }
  2621.  
  2622.         XCHG    EAX,EDX
  2623.  
  2624.         {       limit the length to 255 }
  2625.  
  2626.         CMP     ECX,255
  2627.         JBE     @@skip
  2628.         MOV     ECX,255
  2629. @@skip:
  2630.         MOV     [EDX],CL
  2631.  
  2632.         {       copy the source to destination + 1 }
  2633.  
  2634.         INC     EDX
  2635.         JMP     Move
  2636. end;
  2637.  
  2638.  
  2639. procedure       __PasToCStr;
  2640. asm
  2641. {     ->EAX     Pointer to source       }
  2642. {       EDX     Pointer to destination  }
  2643.  
  2644.         PUSH    ESI
  2645.         PUSH    EDI
  2646.  
  2647.         MOV     ESI,EAX
  2648.         MOV     EDI,EDX
  2649.  
  2650.         XOR     ECX,ECX
  2651.         MOV     CL,[ESI]
  2652.         INC     ESI
  2653.  
  2654.         REP     MOVSB
  2655.         MOV     byte ptr [EDI],CL       { Append terminator: CL is zero here }
  2656.  
  2657.         POP     EDI
  2658.         POP     ESI
  2659. end;
  2660.  
  2661. procedure       _SetElem;
  2662. asm
  2663.         {       PROCEDURE _SetElem( VAR d: SET; elem, size: Byte);      }
  2664.         {       EAX     =       dest address                            }
  2665.         {       DL      =       element number                          }
  2666.         {       CL      =       size of set                                     }
  2667.  
  2668.         PUSH    EBX
  2669.         PUSH    EDI
  2670.  
  2671.         MOV     EDI,EAX
  2672.  
  2673.         XOR     EBX,EBX { zero extend set size into ebx }
  2674.         MOV     BL,CL
  2675.         MOV     ECX,EBX { and use it for the fill       }
  2676.  
  2677.         XOR     EAX,EAX { for zero fill                 }
  2678.         REP     STOSB
  2679.  
  2680.         SUB     EDI,EBX { point edi at beginning of set again   }
  2681.  
  2682.         INC     EAX             { eax is still zero - make it 1 }
  2683.         MOV     CL,DL
  2684.         ROL     AL,CL   { generate a mask               }
  2685.         SHR     ECX,3   { generate the index            }
  2686.         CMP     ECX,EBX { if index >= siz then exit     }
  2687.         JAE     @@exit
  2688.         OR      [EDI+ECX],AL{ set bit                   }
  2689.  
  2690. @@exit:
  2691.         POP     EDI
  2692.         POP     EBX
  2693. end;
  2694.  
  2695. procedure       _SetRange;
  2696. asm
  2697. {       PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET );  }
  2698. { ->AL  low limit of range      }
  2699. {       DL      high limit of range     }
  2700. {       ECX     Pointer to set          }
  2701. {       AH      size of set             }
  2702.  
  2703.         PUSH    EBX
  2704.         PUSH    ESI
  2705.         PUSH    EDI
  2706.  
  2707.         XOR     EBX,EBX { EBX = set size                }
  2708.         MOV     BL,AH
  2709.         MOVZX   ESI,AL  { ESI = low zero extended       }
  2710.         MOVZX   EDX,DL  { EDX = high zero extended      }
  2711.         MOV     EDI,ECX
  2712.  
  2713. {       clear the set                                   }
  2714.  
  2715.         MOV     ECX,EBX
  2716.         XOR     EAX,EAX
  2717.         REP     STOSB
  2718.  
  2719. {       prepare for setting the bits                    }
  2720.  
  2721.         SUB     EDI,EBX { point EDI at start of set     }
  2722.         SHL     EBX,3   { EBX = highest bit in set + 1  }
  2723.         CMP     EDX,EBX
  2724.         JB      @@inrange
  2725.         LEA     EDX,[EBX-1]     { ECX = highest bit in set      }
  2726.  
  2727. @@inrange:
  2728.         CMP     ESI,EDX { if lo > hi then exit;         }
  2729.         JA      @@exit
  2730.  
  2731.         DEC     EAX     { loMask = 0xff << (lo & 7)             }
  2732.         MOV     ECX,ESI
  2733.         AND     CL,07H
  2734.         SHL     AL,CL
  2735.  
  2736.         SHR     ESI,3   { loIndex = lo >> 3;            }
  2737.  
  2738.         MOV     CL,DL   { hiMask = 0xff >> (7 - (hi & 7));      }
  2739.         NOT     CL
  2740.         AND     CL,07
  2741.         SHR     AH,CL
  2742.  
  2743.         SHR     EDX,3   { hiIndex = hi >> 3;            }
  2744.  
  2745.         ADD     EDI,ESI { point EDI to set[loIndex]     }
  2746.         MOV     ECX,EDX
  2747.         SUB     ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0)     }
  2748.         JNE     @@else
  2749.  
  2750.         AND     AL,AH   { set[loIndex] = hiMask & loMask;       }
  2751.         MOV     [EDI],AL
  2752.         JMP     @@exit
  2753.  
  2754. @@else:
  2755.         STOSB           { set[loIndex++] = loMask;      }
  2756.         DEC     ECX
  2757.         MOV     AL,0FFH { while (loIndex < hiIndex)     }
  2758.         REP     STOSB   {   set[loIndex++] = 0xff;      }
  2759.         MOV     [EDI],AH        { set[hiIndex] = hiMask;        }
  2760.  
  2761. @@exit:
  2762.         POP     EDI
  2763.         POP     ESI
  2764.         POP     EBX
  2765. end;
  2766.  
  2767. procedure       _SetEq;
  2768. asm
  2769. {       FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode;   }
  2770. {       EAX     =       left operand    }
  2771. {       EDX     =       right operand   }
  2772. {       CL      =       size of set     }
  2773.  
  2774.         PUSH    ESI
  2775.         PUSH    EDI
  2776.  
  2777.         MOV     ESI,EAX
  2778.         MOV     EDI,EDX
  2779.  
  2780.         AND     ECX,0FFH
  2781.         REP     CMPSB
  2782.  
  2783.         POP     EDI
  2784.         POP     ESI
  2785. end;
  2786.  
  2787. procedure       _SetLe;
  2788. asm
  2789. {       FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode;   }
  2790. {       EAX     =       left operand            }
  2791. {       EDX     =       right operand           }
  2792. {       CL      =       size of set (>0 && <= 32)       }
  2793.  
  2794. @@loop:
  2795.         MOV     CH,[EDX]
  2796.         NOT     CH
  2797.         AND     CH,[EAX]
  2798.         JNE     @@exit
  2799.         INC     EDX
  2800.         INC     EAX
  2801.         DEC     CL
  2802.         JNZ     @@loop
  2803. @@exit:
  2804. end;
  2805.  
  2806. procedure       _SetIntersect;
  2807. asm
  2808. {       PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);}
  2809. {       EAX     =       destination operand             }
  2810. {       EDX     =       source operand                  }
  2811. {       CL      =       size of set (0 < size <= 32)    }
  2812.  
  2813. @@loop:
  2814.         MOV     CH,[EDX]
  2815.         INC     EDX
  2816.         AND     [EAX],CH
  2817.         INC     EAX
  2818.         DEC     CL
  2819.         JNZ     @@loop
  2820. end;
  2821.  
  2822. procedure       _SetUnion;
  2823. asm
  2824. {       PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte);        }
  2825. {       EAX     =       destination operand             }
  2826. {       EDX     =       source operand                  }
  2827. {       CL      =       size of set (0 < size <= 32)    }
  2828.  
  2829. @@loop:
  2830.         MOV     CH,[EDX]
  2831.         INC     EDX
  2832.         OR      [EAX],CH
  2833.         INC     EAX
  2834.         DEC     CL
  2835.         JNZ     @@loop
  2836. end;
  2837.  
  2838. procedure       _SetSub;
  2839. asm
  2840. {       PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte);  }
  2841. {       EAX     =       destination operand             }
  2842. {       EDX     =       source operand                  }
  2843. {       CL      =       size of set (0 < size <= 32)    }
  2844.  
  2845. @@loop:
  2846.         MOV     CH,[EDX]
  2847.         NOT     CH
  2848.         INC     EDX
  2849.         AND     [EAX],CH
  2850.         INC     EAX
  2851.         DEC     CL
  2852.         JNZ     @@loop
  2853. end;
  2854.  
  2855. procedure       _SetExpand;
  2856. asm
  2857. {       PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte);     }
  2858. {     ->EAX     Pointer to source (packed set)          }
  2859. {       EDX     Pointer to destination (expanded set)   }
  2860. {       CH      high byte of source                     }
  2861. {       CL      low byte of source                      }
  2862.  
  2863. {       algorithm:              }
  2864. {       clear low bytes         }
  2865. {       copy high-low+1 bytes   }
  2866. {       clear 31-high bytes     }
  2867.  
  2868.         PUSH    ESI
  2869.         PUSH    EDI
  2870.  
  2871.         MOV     ESI,EAX
  2872.         MOV     EDI,EDX
  2873.  
  2874.         MOV     EDX,ECX { save low, high in dl, dh      }
  2875.         XOR     ECX,ECX
  2876.         XOR     EAX,EAX
  2877.  
  2878.         MOV     CL,DL   { clear low bytes               }
  2879.         REP     STOSB
  2880.  
  2881.         MOV     CL,DH   { copy high - low bytes }
  2882.         SUB     CL,DL
  2883.         REP     MOVSB
  2884.  
  2885.         MOV     CL,32   { copy 32 - high bytes  }
  2886.         SUB     CL,DH
  2887.         REP     STOSB
  2888.  
  2889.         POP     EDI
  2890.         POP     ESI
  2891. end;
  2892.  
  2893. procedure       _Str2Ext;                       external;       {$L StrExt  }
  2894. procedure       _Str0Ext;                       external;       {   StrExt  }
  2895. procedure       _Str1Ext;                       external;       {   StrExt  }
  2896.  
  2897. procedure       _ValExt;                        external;       {$L ValExt  }
  2898.  
  2899. procedure       _Pow10;                         external;       {$L Pow10   }
  2900. procedure       FPower10;                       external;       {   Pow10   }
  2901. procedure       _Real2Ext;                      external;       {$L Real2Ext}
  2902. procedure       _Ext2Real;                      external;       {$L Ext2Real}
  2903.  
  2904. const
  2905.         ovtInstanceSize = -8;   { Offset of instance size in OBJECTs    }
  2906.         ovtVmtPtrOffs   = -4;
  2907.  
  2908. procedure       _ObjSetup;
  2909. asm
  2910. {       FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; }
  2911. {     ->EAX     Pointer to self (possibly nil)  }
  2912. {       EDX     Pointer to vmt  (possibly nil)  }
  2913. {     <-EAX     Pointer to self                 }
  2914. {       EDX     <> 0: an object was allocated   }
  2915. {       Z-Flag  Set: failure, Cleared: Success  }
  2916.  
  2917.         CMP     EDX,1   { is vmt = 0, indicating a call         }
  2918.         JAE     @@skip1 { from a constructor?                   }
  2919.         RET                     { return immediately with Z-flag cleared        }
  2920.  
  2921. @@skip1:
  2922.         PUSH    ECX
  2923.         TEST    EAX,EAX { is self already allocated?            }
  2924.         JNE     @@noAlloc
  2925.         MOV     EAX,[EDX].ovtInstanceSize
  2926.         TEST    EAX,EAX
  2927.         JE      @@zeroSize
  2928.         PUSH    EDX
  2929.         CALL    MemoryManager.GetMem
  2930.         POP     EDX
  2931.         TEST    EAX,EAX
  2932.         JZ      @@fail
  2933.         MOV     ECX,[EDX].ovtVmtPtrOffs
  2934.         TEST    ECX,ECX
  2935.         JL      @@skip
  2936.         MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
  2937. @@skip:
  2938.         TEST    EAX,EAX { clear zero flag                               }
  2939.         POP     ECX
  2940.         RET
  2941.  
  2942. @@fail:
  2943.         XOR     EDX,EDX
  2944.         POP     ECX
  2945.         RET
  2946.  
  2947. @@zeroSize:
  2948.         XOR     EDX,EDX
  2949.         CMP     EAX,1   { clear zero flag - we were successful (kind of) }
  2950.         POP     ECX
  2951.         RET
  2952.  
  2953. @@noAlloc:
  2954.         MOV     ECX,[EDX].ovtVmtPtrOffs
  2955.         TEST    ECX,ECX
  2956.         JL      @@exit
  2957.         MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
  2958. @@exit:
  2959.         XOR     EDX,EDX { clear allocated flag                  }
  2960.         TEST    EAX,EAX { clear zero flag                               }
  2961.         POP     ECX
  2962. end;
  2963.  
  2964. procedure       _ObjCopy;
  2965. asm
  2966. {       PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint);    }
  2967. {     ->EAX     Pointer to destination          }
  2968. {       EDX     Pointer to source               }
  2969. {       ECX     Offset of vmt in those objects. }
  2970.  
  2971.         PUSH    EBX
  2972.         PUSH    ESI
  2973.         PUSH    EDI
  2974.  
  2975.         MOV     ESI,EDX
  2976.         MOV     EDI,EAX
  2977.  
  2978.         LEA     EAX,[EDI+ECX]   { remember pointer to dest vmt pointer  }
  2979.         MOV     EDX,[EAX]       { fetch dest vmt pointer        }
  2980.  
  2981.         MOV     EBX,[EDX].ovtInstanceSize
  2982.  
  2983.         MOV     ECX,EBX { copy size DIV 4 dwords        }
  2984.         SHR     ECX,2
  2985.         REP     MOVSD
  2986.  
  2987.         MOV     ECX,EBX { copy size MOD 4 bytes }
  2988.         AND     ECX,3
  2989.         REP     MOVSB
  2990.  
  2991.         MOV     [EAX],EDX       { restore dest vmt              }
  2992.  
  2993.         POP     EDI
  2994.         POP     ESI
  2995.         POP     EBX
  2996. end;
  2997.  
  2998. procedure       _Fail;
  2999. asm
  3000. {       FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT;     }
  3001. {     ->EAX     Pointer to self (possibly nil)  }
  3002. {       EDX     <> 0: Object must be deallocated        }
  3003. {     <-EAX     Nil                                     }
  3004.  
  3005.         TEST    EDX,EDX
  3006.         JE      @@exit  { if no object was allocated, return    }
  3007.         CALL    _FreeMem
  3008. @@exit:
  3009.         XOR     EAX,EAX
  3010. end;
  3011.  
  3012. procedure       _FpuInit;
  3013. //const cwDefault: Word = $1332 { $133F};
  3014. asm
  3015.         FNINIT
  3016.         FWAIT
  3017.         FLDCW   Default8087CW
  3018. end;
  3019.  
  3020. procedure       _BoundErr;
  3021. asm
  3022.         MOV     AL,reRangeError
  3023.         JMP     Error
  3024. end;
  3025.  
  3026. procedure       _IntOver;
  3027. asm
  3028.         MOV     AL,reIntOverflow
  3029.         JMP     Error
  3030. end;
  3031.  
  3032.  
  3033. function TObject.ClassType: TClass;
  3034. asm
  3035.         MOV     EAX,[EAX]
  3036. end;
  3037.  
  3038. class function TObject.ClassName: ShortString;
  3039. asm
  3040.         { ->    EAX VMT                         }
  3041.         {       EDX Pointer to result string    }
  3042.         PUSH    ESI
  3043.         PUSH    EDI
  3044.         MOV     EDI,EDX
  3045.         MOV     ESI,[EAX].vmtClassName
  3046.         XOR     ECX,ECX
  3047.         MOV     CL,[ESI]
  3048.         INC     ECX
  3049.         REP     MOVSB
  3050.         POP     EDI
  3051.         POP     ESI
  3052. end;
  3053.  
  3054. class function TObject.ClassNameIs(const Name: string): Boolean;
  3055. asm
  3056.         PUSH    EBX
  3057.         XOR     EBX,EBX
  3058.         OR      EDX,EDX
  3059.         JE      @@exit
  3060.         MOV     EAX,[EAX].vmtClassName
  3061.         XOR     ECX,ECX
  3062.         MOV     CL,[EAX]
  3063.         CMP     ECX,[EDX-4]
  3064.         JNE     @@exit
  3065.         DEC     EDX
  3066. @@loop:
  3067.         MOV     BH,[EAX+ECX]
  3068.         XOR     BH,[EDX+ECX]
  3069.         AND     BH,0DFH
  3070.         JNE     @@exit
  3071.         DEC     ECX
  3072.         JNE     @@loop
  3073.         INC     EBX
  3074. @@exit:
  3075.         MOV     AL,BL
  3076.         POP     EBX
  3077. end;
  3078.  
  3079. class function TObject.ClassParent: TClass;
  3080. asm
  3081.         MOV     EAX,[EAX].vmtParent
  3082.         TEST    EAX,EAX
  3083.         JE      @@exit
  3084.         MOV     EAX,[EAX]
  3085. @@exit:
  3086. end;
  3087.  
  3088. class function TObject.NewInstance: TObject;
  3089. asm
  3090.         PUSH    EAX
  3091.         MOV     EAX,[EAX].vmtInstanceSize
  3092.         CALL    _GetMem
  3093.         MOV     EDX,EAX
  3094.         POP     EAX
  3095.         JMP     TObject.InitInstance
  3096. end;
  3097.  
  3098. procedure TObject.FreeInstance;
  3099. asm
  3100.         PUSH    EBX
  3101.         PUSH    ESI
  3102.         MOV     EBX,EAX
  3103.         MOV     ESI,EAX
  3104. @@loop:
  3105.         MOV     ESI,[ESI]
  3106.         MOV     EDX,[ESI].vmtInitTable
  3107.         MOV     ESI,[ESI].vmtParent
  3108.         TEST    EDX,EDX
  3109.         JE      @@skip
  3110.         CALL    _FinalizeRecord
  3111.         MOV     EAX,EBX
  3112. @@skip:
  3113.         TEST    ESI,ESI
  3114.         JNE     @@loop
  3115.  
  3116.         CALL    _FreeMem
  3117.         POP     ESI
  3118.         POP     EBX
  3119. end;
  3120.  
  3121. class function TObject.InstanceSize: Longint;
  3122. asm
  3123.         MOV     EAX,[EAX].vmtInstanceSize
  3124. end;
  3125.  
  3126. constructor TObject.Create;
  3127. begin
  3128. end;
  3129.  
  3130. destructor TObject.Destroy;
  3131. begin
  3132. end;
  3133.  
  3134. procedure TObject.Free;
  3135. asm
  3136.         TEST    EAX,EAX
  3137.         JE      @@exit
  3138.         MOV     ECX,[EAX]
  3139.         MOV     DL,1
  3140.         CALL    dword ptr [ECX].vmtDestroy
  3141. @@exit:
  3142. end;
  3143.  
  3144. class function TObject.InitInstance(Instance: Pointer): TObject;
  3145. asm
  3146.         PUSH    EBX
  3147.         PUSH    ESI
  3148.         PUSH    EDI
  3149.         MOV     EBX,EAX
  3150.         MOV     EDI,EDX
  3151.         STOSD
  3152.         MOV     ECX,[EBX].vmtInstanceSize
  3153.         XOR     EAX,EAX
  3154.         PUSH    ECX
  3155.         SHR     ECX,2
  3156.         DEC     ECX
  3157.         REP     STOSD
  3158.         POP     ECX
  3159.         AND     ECX,3
  3160.         REP     STOSB
  3161.         MOV     EAX,EDX
  3162.         MOV     EDX,ESP
  3163. @@0:    MOV     ECX,[EBX].vmtIntfTable
  3164.         TEST    ECX,ECX
  3165.         JE      @@1
  3166.         PUSH    ECX
  3167. @@1:    MOV     EBX,[EBX].vmtParent
  3168.         TEST    EBX,EBX
  3169.         JE      @@2
  3170.         MOV     EBX,[EBX]
  3171.         JMP     @@0
  3172. @@2:    CMP     ESP,EDX
  3173.         JE      @@5
  3174. @@3:    POP     EBX
  3175.         MOV     ECX,[EBX].TInterfaceTable.EntryCount
  3176.         ADD     EBX,4
  3177. @@4:    MOV     ESI,[EBX].TInterfaceEntry.VTable
  3178.         MOV     EDI,[EBX].TInterfaceEntry.IOffset
  3179.         MOV     [EAX+EDI],ESI
  3180.         ADD     EBX,TYPE TInterfaceEntry
  3181.         DEC     ECX
  3182.         JNE     @@4
  3183.         CMP     ESP,EDX
  3184.         JNE     @@3
  3185. @@5:    POP     EDI
  3186.         POP     ESI
  3187.         POP     EBX
  3188. end;
  3189.  
  3190. procedure TObject.CleanupInstance;
  3191. asm
  3192.         PUSH    EBX
  3193.         PUSH    ESI
  3194.         MOV     EBX,EAX
  3195.         MOV     ESI,EAX
  3196. @@loop:
  3197.         MOV     ESI,[ESI]
  3198.         MOV     EDX,[ESI].vmtInitTable
  3199.         MOV     ESI,[ESI].vmtParent
  3200.         TEST    EDX,EDX
  3201.         JE      @@skip
  3202.         CALL    _FinalizeRecord
  3203.         MOV     EAX,EBX
  3204. @@skip:
  3205.         TEST    ESI,ESI
  3206.         JNE     @@loop
  3207.  
  3208.         POP     ESI
  3209.         POP     EBX
  3210. end;
  3211.  
  3212. function TObject.GetInterface(const IID: TGUID; out Obj): Boolean;
  3213. var
  3214.   InterfaceEntry: PInterfaceEntry;
  3215. begin
  3216.   InterfaceEntry := GetInterfaceEntry(IID);
  3217.   if InterfaceEntry <> nil then
  3218.   begin
  3219.     Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset);
  3220.     IUnknown(Obj)._AddRef;
  3221.     Result := True;
  3222.   end else
  3223.   begin
  3224.     Pointer(Obj) := nil;
  3225.     Result := False;
  3226.   end;
  3227. end;
  3228.  
  3229. class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
  3230. asm
  3231.         PUSH    EBX
  3232.         PUSH    ESI
  3233.         MOV     EBX,EAX
  3234. @@1:    MOV     EAX,[EBX].vmtIntfTable
  3235.         TEST    EAX,EAX
  3236.         JE      @@4
  3237.         MOV     ECX,[EAX].TInterfaceTable.EntryCount
  3238.         ADD     EAX,4
  3239. @@2:    MOV     ESI,[EDX].Integer[0]
  3240.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[0]
  3241.         JNE     @@3
  3242.         MOV     ESI,[EDX].Integer[4]
  3243.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[4]
  3244.         JNE     @@3
  3245.         MOV     ESI,[EDX].Integer[8]
  3246.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[8]
  3247.         JNE     @@3
  3248.         MOV     ESI,[EDX].Integer[12]
  3249.         CMP     ESI,[EAX].TInterfaceEntry.IID.Integer[12]
  3250.         JE      @@5
  3251. @@3:    ADD     EAX,type TInterfaceEntry
  3252.         DEC     ECX
  3253.         JNE     @@2
  3254. @@4:    MOV     EBX,[EBX].vmtParent
  3255.         TEST    EBX,EBX
  3256.         JE      @@4a
  3257.         MOV     EBX,[EBX]
  3258.         JMP     @@1
  3259. @@4a:   XOR     EAX,EAX
  3260. @@5:    POP     ESI
  3261.         POP     EBX
  3262. end;
  3263.  
  3264. class function TObject.GetInterfaceTable: PInterfaceTable;
  3265. asm
  3266.         MOV     EAX,[EAX].vmtIntfTable
  3267. end;
  3268.  
  3269.  
  3270. procedure       _IsClass;
  3271. asm
  3272.         { ->    EAX     left operand (class)    }
  3273.         {       EDX VMT of right operand        }
  3274.         { <-    AL      left is derived from right      }
  3275.         TEST    EAX,EAX
  3276.         JE      @@exit
  3277. @@loop:
  3278.         MOV     EAX,[EAX]
  3279.         CMP     EAX,EDX
  3280.         JE      @@success
  3281.         MOV     EAX,[EAX].vmtParent
  3282.         TEST    EAX,EAX
  3283.         JNE     @@loop
  3284.         JMP     @@exit
  3285. @@success:
  3286.         MOV     AL,1
  3287. @@exit:
  3288. end;
  3289.  
  3290.  
  3291. procedure       _AsClass;
  3292. asm
  3293.         { ->    EAX     left operand (class)    }
  3294.         {       EDX VMT of right operand        }
  3295.         { <-    EAX      if left is derived from right, else runtime error      }
  3296.         TEST    EAX,EAX
  3297.         JE      @@exit
  3298.         MOV     ECX,EAX
  3299. @@loop:
  3300.         MOV     ECX,[ECX]
  3301.         CMP     ECX,EDX
  3302.         JE      @@exit
  3303.         MOV     ECX,[ECX].vmtParent
  3304.         TEST    ECX,ECX
  3305.         JNE     @@loop
  3306.  
  3307.         {       do runtime error        }
  3308.         MOV     AL,reInvalidCast
  3309.         JMP     Error
  3310.  
  3311. @@exit:
  3312. end;
  3313.  
  3314.  
  3315. procedure       GetDynaMethod;
  3316. {       function        GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;       }
  3317. asm
  3318.         { ->    EAX     vmt of class            }
  3319.         {       BX      dynamic method index    }
  3320.         { <-    EBX pointer to routine  }
  3321.         {       ZF = 0 if found         }
  3322.         {       trashes: EAX, ECX               }
  3323.  
  3324.         PUSH    EDI
  3325.         XCHG    EAX,EBX
  3326.         JMP     @@haveVMT
  3327. @@outerLoop:
  3328.         MOV     EBX,[EBX]
  3329. @@haveVMT:
  3330.         MOV     EDI,[EBX].vmtDynamicTable
  3331.         TEST    EDI,EDI
  3332.         JE      @@parent
  3333.         MOVZX   ECX,word ptr [EDI]
  3334.         PUSH    ECX
  3335.         ADD     EDI,2
  3336.         REPNE   SCASW
  3337.         JE      @@found
  3338.         POP     ECX
  3339. @@parent:
  3340.         MOV     EBX,[EBX].vmtParent
  3341.         TEST    EBX,EBX
  3342.         JNE     @@outerLoop
  3343.         JMP     @@exit
  3344.  
  3345. @@found:
  3346.         POP     EAX
  3347.         ADD     EAX,EAX
  3348.         SUB     EAX,ECX         { this will always clear the Z-flag ! }
  3349.         MOV     EBX,[EDI+EAX*2-4]
  3350.  
  3351. @@exit:
  3352.         POP     EDI
  3353. end;
  3354.  
  3355. procedure       _CallDynaInst;
  3356. asm
  3357.         PUSH    EAX
  3358.         PUSH    ECX
  3359.         MOV     EAX,[EAX]
  3360.         CALL    GetDynaMethod
  3361.         POP     ECX
  3362.         POP     EAX
  3363.         JE      @@Abstract
  3364.         JMP     EBX
  3365. @@Abstract:
  3366.         POP     ECX
  3367.         JMP     _AbstractError
  3368. end;
  3369.  
  3370.  
  3371. procedure       _CallDynaClass;
  3372. asm
  3373.         PUSH    EAX
  3374.         PUSH    ECX
  3375.         CALL    GetDynaMethod
  3376.         POP     ECX
  3377.         POP     EAX
  3378.         JE      @@Abstract
  3379.         JMP     EBX
  3380. @@Abstract:
  3381.         POP     ECX
  3382.         JMP     _AbstractError
  3383. end;
  3384.  
  3385.  
  3386. procedure       _FindDynaInst;
  3387. asm
  3388.         PUSH    EBX
  3389.         MOV     EBX,EDX
  3390.         MOV     EAX,[EAX]
  3391.         CALL    GetDynaMethod
  3392.         MOV     EAX,EBX
  3393.         POP     EBX
  3394.         JNE     @@exit
  3395.         POP     ECX
  3396.         JMP     _AbstractError
  3397. @@exit:
  3398. end;
  3399.  
  3400.  
  3401. procedure       _FindDynaClass;
  3402. asm
  3403.         PUSH    EBX
  3404.         MOV     EBX,EDX
  3405.         CALL    GetDynaMethod
  3406.         MOV     EAX,EBX
  3407.         POP     EBX
  3408.         JNE     @@exit
  3409.         POP     ECX
  3410.         JMP     _AbstractError
  3411. @@exit:
  3412. end;
  3413.  
  3414.  
  3415. class function TObject.InheritsFrom(AClass: TClass): Boolean;
  3416. asm
  3417.         { ->    EAX     Pointer to our class    }
  3418.         {       EDX     Pointer to AClass               }
  3419.         { <-    AL      Boolean result          }
  3420.         JMP     @@haveVMT
  3421. @@loop:
  3422.         MOV     EAX,[EAX]
  3423. @@haveVMT:
  3424.         CMP     EAX,EDX
  3425.         JE      @@success
  3426.         MOV     EAX,[EAX].vmtParent
  3427.         TEST    EAX,EAX
  3428.         JNE     @@loop
  3429.         JMP     @@exit
  3430. @@success:
  3431.         MOV     AL,1
  3432. @@exit:
  3433. end;
  3434.  
  3435.  
  3436. class function TObject.ClassInfo: Pointer;
  3437. asm
  3438.         MOV     EAX,[EAX].vmtTypeInfo
  3439. end;
  3440.  
  3441.  
  3442. function TObject.SafeCallException(ExceptObject: TObject;
  3443.   ExceptAddr: Pointer): Integer;
  3444. begin
  3445.   Result := $8000FFFF; { E_UNEXPECTED }
  3446. end;
  3447.  
  3448.  
  3449. procedure TObject.DefaultHandler(var Message);
  3450. begin
  3451. end;
  3452.  
  3453.  
  3454. procedure TObject.Dispatch(var Message);
  3455. asm
  3456.         PUSH    EBX
  3457.         MOV     BX,[EDX]
  3458.         OR      BX,BX
  3459.         JE      @@default
  3460.         CMP     BX,0C000H
  3461.         JAE     @@default
  3462.         PUSH    EAX
  3463.         MOV     EAX,[EAX]
  3464.         CALL    GetDynaMethod
  3465.         POP     EAX
  3466.         JE      @@default
  3467.         MOV     ECX,EBX
  3468.         POP     EBX
  3469.         JMP     ECX
  3470.  
  3471. @@default:
  3472.         POP     EBX
  3473.         MOV     ECX,[EAX]
  3474.         JMP     dword ptr [ECX].vmtDefaultHandler
  3475. end;
  3476.  
  3477.  
  3478. class function TObject.MethodAddress(const Name: ShortString): Pointer;
  3479. asm
  3480.         { ->    EAX     Pointer to class        }
  3481.         {       EDX     Pointer to name }
  3482.         PUSH    EBX
  3483.         PUSH    ESI
  3484.         PUSH    EDI
  3485.         XOR     ECX,ECX
  3486.         XOR     EDI,EDI
  3487.         MOV     BL,[EDX]
  3488.         JMP     @@haveVMT
  3489. @@outer:                                { upper 16 bits of ECX are 0 !  }
  3490.         MOV     EAX,[EAX]
  3491. @@haveVMT:
  3492.         MOV     ESI,[EAX].vmtMethodTable
  3493.         TEST    ESI,ESI
  3494.         JE      @@parent
  3495.         MOV     DI,[ESI]                { EDI := method count           }
  3496.         ADD     ESI,2
  3497. @@inner:                                { upper 16 bits of ECX are 0 !  }
  3498.         MOV     CL,[ESI+6]              { compare length of strings     }
  3499.         CMP     CL,BL
  3500.         JE      @@cmpChar
  3501. @@cont:                                 { upper 16 bits of ECX are 0 !  }
  3502.         MOV     CX,[ESI]                { fetch length of method desc   }
  3503.         ADD     ESI,ECX                 { point ESI to next method      }
  3504.         DEC     EDI
  3505.         JNZ     @@inner
  3506. @@parent:
  3507.         MOV     EAX,[EAX].vmtParent     { fetch parent vmt              }
  3508.         TEST    EAX,EAX
  3509.         JNE     @@outer
  3510.         JMP     @@exit                  { return NIL                    }
  3511.  
  3512. @@notEqual:
  3513.         MOV     BL,[EDX]                { restore BL to length of name  }
  3514.         JMP     @@cont
  3515.  
  3516. @@cmpChar:                              { upper 16 bits of ECX are 0 !  }
  3517.         MOV     CH,0                    { upper 24 bits of ECX are 0 !  }
  3518. @@cmpCharLoop:
  3519.         MOV     BL,[ESI+ECX+6]          { case insensitive string cmp   }
  3520.         XOR     BL,[EDX+ECX+0]          { last char is compared first   }
  3521.         AND     BL,$DF
  3522.         JNE     @@notEqual
  3523.         DEC     ECX                     { ECX serves as counter         }
  3524.         JNZ     @@cmpCharLoop
  3525.  
  3526.         { found it }
  3527.         MOV     EAX,[ESI+2]
  3528.  
  3529. @@exit:
  3530.         POP     EDI
  3531.         POP     ESI
  3532.         POP     EBX
  3533. end;
  3534.  
  3535.  
  3536. class function TObject.MethodName(Address: Pointer): ShortString;
  3537. asm
  3538.         { ->    EAX     Pointer to class        }
  3539.         {       EDX     Address         }
  3540.         {       ECX Pointer to result   }
  3541.         PUSH    EBX
  3542.         PUSH    ESI
  3543.         PUSH    EDI
  3544.         MOV     EDI,ECX
  3545.         XOR     EBX,EBX
  3546.         XOR     ECX,ECX
  3547.         JMP     @@haveVMT
  3548. @@outer:
  3549.         MOV     EAX,[EAX]
  3550. @@haveVMT:
  3551.         MOV     ESI,[EAX].vmtMethodTable { fetch pointer to method table }
  3552.         TEST    ESI,ESI
  3553.         JE      @@parent
  3554.         MOV     CX,[ESI]
  3555.         ADD     ESI,2
  3556. @@inner:
  3557.         CMP     EDX,[ESI+2]
  3558.         JE      @@found
  3559.         MOV     BX,[ESI]
  3560.         ADD     ESI,EBX
  3561.         DEC     ECX
  3562.         JNZ     @@inner
  3563. @@parent:
  3564.         MOV     EAX,[EAX].vmtParent
  3565.         TEST    EAX,EAX
  3566.         JNE     @@outer
  3567.         MOV     [EDI],AL
  3568.         JMP     @@exit
  3569.  
  3570. @@found:
  3571.         ADD     ESI,6
  3572.         XOR     ECX,ECX
  3573.         MOV     CL,[ESI]
  3574.         INC     ECX
  3575.         REP     MOVSB
  3576.  
  3577. @@exit:
  3578.         POP     EDI
  3579.         POP     ESI
  3580.         POP     EBX
  3581. end;
  3582.  
  3583.  
  3584. function TObject.FieldAddress(const Name: ShortString): Pointer;
  3585. asm
  3586.         { ->    EAX     Pointer to instance     }
  3587.         {       EDX     Pointer to name }
  3588.         PUSH    EBX
  3589.         PUSH    ESI
  3590.         PUSH    EDI
  3591.         XOR     ECX,ECX
  3592.         XOR     EDI,EDI
  3593.         MOV     BL,[EDX]
  3594.  
  3595.         PUSH    EAX                     { save instance pointer         }
  3596.  
  3597. @@outer:
  3598.         MOV     EAX,[EAX]               { fetch class pointer           }
  3599.         MOV     ESI,[EAX].vmtFieldTable
  3600.         TEST    ESI,ESI
  3601.         JE      @@parent
  3602.         MOV     DI,[ESI]                { fetch count of fields         }
  3603.         ADD     ESI,6
  3604. @@inner:
  3605.         MOV     CL,[ESI+6]              { compare string lengths        }
  3606.         CMP     CL,BL
  3607.         JE      @@cmpChar
  3608. @@cont:
  3609.         LEA     ESI,[ESI+ECX+7] { point ESI to next field       }
  3610.         DEC     EDI
  3611.         JNZ     @@inner
  3612. @@parent:
  3613.         MOV     EAX,[EAX].vmtParent     { fetch parent VMT              }
  3614.         TEST    EAX,EAX
  3615.         JNE     @@outer
  3616.         POP     EDX                     { forget instance, return Nil   }
  3617.         JMP     @@exit
  3618.  
  3619. @@notEqual:
  3620.         MOV     BL,[EDX]                { restore BL to length of name  }
  3621.         MOV     CL,[ESI+6]              { ECX := length of field name   }
  3622.         JMP     @@cont
  3623.  
  3624. @@cmpChar:
  3625.         MOV     BL,[ESI+ECX+6]  { case insensitive string cmp   }
  3626.         XOR     BL,[EDX+ECX+0]  { starting with last char       }
  3627.         AND     BL,$DF
  3628.         JNE     @@notEqual
  3629.         DEC     ECX                     { ECX serves as counter         }
  3630.         JNZ     @@cmpChar
  3631.  
  3632.         { found it }
  3633.         MOV     EAX,[ESI]           { result is field offset plus ...   }
  3634.         POP     EDX
  3635.         ADD     EAX,EDX         { instance pointer              }
  3636.  
  3637. @@exit:
  3638.         POP     EDI
  3639.         POP     ESI
  3640.         POP     EBX
  3641. end;
  3642.  
  3643.  
  3644. const { copied from xx.h }
  3645.   cContinuable        = 0;
  3646.   cNonContinuable     = 1;
  3647.   cUnwinding          = 2;
  3648.   cUnwindingForExit   = 4;
  3649.   cUnwindInProgress   = cUnwinding or cUnwindingForExit;
  3650.   cDelphiException    = $0EEDFACE;
  3651.   cDelphiReRaise      = $0EEDFACF;
  3652.   cDelphiExcept       = $0EEDFAD0;
  3653.   cDelphiFinally      = $0EEDFAD1;
  3654.   cDelphiTerminate    = $0EEDFAD2;
  3655.   cDelphiUnhandled    = $0EEDFAD3;
  3656.   cNonDelphiException = $0EEDFAD4;
  3657.   cDelphiExitFinally  = $0EEDFAD5;
  3658.  
  3659. type
  3660.   JmpInstruction =
  3661.   packed record
  3662.     opCode:   Byte;
  3663.     distance: Longint;
  3664.   end;
  3665.   TExcDescEntry =
  3666.   record
  3667.     vTable:  Pointer;
  3668.     handler: Pointer;
  3669.   end;
  3670.   PExcDesc = ^TExcDesc;
  3671.   TExcDesc =
  3672.   packed record
  3673.     jmp: JmpInstruction;
  3674.     case Integer of
  3675.     0:      (instructions: array [0..0] of Byte);
  3676.     1{...}: (cnt: Integer; excTab: array [0..0{cnt-1}] of TExcDescEntry);
  3677.   end;
  3678.  
  3679.   PExcFrame = ^TExcFrame;
  3680.   TExcFrame =
  3681.   record
  3682.     next: PExcFrame;
  3683.     desc: PExcDesc;
  3684.     hEBP: Pointer;
  3685.     case Integer of
  3686.     0:  ( );
  3687.     1:  ( ConstructedObject: Pointer );
  3688.     2:  ( SelfOfMethod: Pointer );
  3689.   end;
  3690.  
  3691.   PExceptionRecord = ^TExceptionRecord;
  3692.   TExceptionRecord =
  3693.   record
  3694.     ExceptionCode        : Longint;
  3695.     ExceptionFlags       : Longint;
  3696.     OuterException       : PExceptionRecord;
  3697.     ExceptionAddress     : Pointer;
  3698.     NumberParameters     : Longint;
  3699.     case {IsOsException:} Boolean of
  3700.     True:  (ExceptionInformation : array [0..14] of Longint);
  3701.     False: (ExceptAddr: Pointer; ExceptObject: Pointer);
  3702.   end;
  3703.  
  3704.   PRaiseFrame = ^TRaiseFrame;
  3705.   TRaiseFrame = record
  3706.     NextRaise: PRaiseFrame;
  3707.     ExceptAddr: Pointer;
  3708.     ExceptObject: TObject;
  3709.     ExceptionRecord: PExceptionRecord;
  3710.   end;
  3711.  
  3712.  
  3713. procedure       _ClassCreate;
  3714. asm
  3715.         { ->    EAX = pointer to VMT      }
  3716.         { <-    EAX = pointer to instance }
  3717.         PUSH    EDX
  3718.         PUSH    ECX
  3719.         PUSH    EBX
  3720.         CALL    dword ptr [EAX].vmtNewInstance
  3721.         XOR     EDX,EDX
  3722.         LEA     ECX,[ESP+16]
  3723.         MOV     EBX,FS:[EDX]
  3724.         MOV     [ECX].TExcFrame.next,EBX
  3725.         MOV     [ECX].TExcFrame.hEBP,EBP
  3726.         MOV     [ECX].TExcFrame.desc,offset @desc
  3727.         MOV     [ECX].TexcFrame.ConstructedObject,EAX   { trick: remember copy to instance }
  3728.         MOV     FS:[EDX],ECX
  3729.         POP     EBX
  3730.         POP     ECX
  3731.         POP     EDX
  3732.         RET
  3733.  
  3734. @desc:
  3735.         JMP     _HandleAnyException
  3736.  
  3737.         {       destroy the object                                                      }
  3738.  
  3739.         MOV     EAX,[ESP+8+9*4]
  3740.         MOV     EAX,[EAX].TExcFrame.ConstructedObject
  3741.         CALL    TObject.Free
  3742.  
  3743.         {       reraise the exception   }
  3744.         CALL    _RaiseAgain
  3745. end;
  3746.  
  3747.  
  3748. procedure       _ClassDestroy;
  3749. asm
  3750.         MOV     EDX,[EAX]
  3751.         CALL    dword ptr [EDX].vmtFreeInstance
  3752. end;
  3753.  
  3754.  
  3755. {
  3756.   The following NotifyXXXX routines are used to "raise" special exceptions
  3757.   as a signaling mechanism to an interested debugger.  If the debugger sets
  3758.   the DebugHook flag to 1 or 2, then all exception processing is tracked by
  3759.   raising these special exceptions.  The debugger *MUST* respond to the
  3760.   debug event with DBG_CONTINE so that normal processing will occur.
  3761. }
  3762.  
  3763. { tell the debugger that the next raise is a re-raise of the current non-Delphi
  3764.   exception }
  3765. procedure       NotifyReRaise;
  3766. asm
  3767.         CMP     BYTE PTR DebugHook,1
  3768.         JBE     @@1
  3769.         PUSH    0
  3770.         PUSH    0
  3771.         PUSH    cContinuable
  3772.         PUSH    cDelphiReRaise
  3773.         CALL    RaiseException
  3774. @@1:
  3775. end;
  3776.  
  3777. { tell the debugger about the raise of a non-Delphi exception }
  3778. procedure       NotifyNonDelphiException;
  3779. asm
  3780.         CMP     BYTE PTR DebugHook,0
  3781.         JE      @@1
  3782.         PUSH    EAX
  3783.         PUSH    EAX
  3784.         PUSH    EDX
  3785.         PUSH    ESP
  3786.         PUSH    2
  3787.         PUSH    cContinuable
  3788.         PUSH    cNonDelphiException
  3789.         CALL    RaiseException
  3790.         ADD     ESP,8
  3791.         POP     EAX
  3792. @@1:
  3793. end;
  3794.  
  3795. { Tell the debugger where the handler for the current exception is located }
  3796. procedure       NotifyExcept;
  3797. asm
  3798.         PUSH    ESP
  3799.         PUSH    1
  3800.         PUSH    cContinuable
  3801.         PUSH    cDelphiExcept           { our magic exception code }
  3802.         CALL    RaiseException
  3803.         ADD     ESP,4
  3804.         POP     EAX
  3805. end;
  3806.  
  3807. procedure       NotifyOnExcept;
  3808. asm
  3809.         CMP     BYTE PTR DebugHook,1
  3810.         JBE     @@1
  3811.         PUSH    EAX
  3812.         PUSH    [EBX].TExcDescEntry.handler
  3813.         JMP     NotifyExcept
  3814. @@1:
  3815. end;
  3816.  
  3817. procedure       NotifyAnyExcept;
  3818. asm
  3819.         CMP     BYTE PTR DebugHook,1
  3820.         JBE     @@1
  3821.         PUSH    EAX
  3822.         PUSH    EBX
  3823.         JMP     NotifyExcept
  3824. @@1:
  3825. end;
  3826.  
  3827. procedure       CheckJmp;
  3828. asm
  3829.         TEST    ECX,ECX
  3830.         JE      @@3
  3831.         MOV     EAX,[ECX + 1]
  3832.         CMP     BYTE PTR [ECX],0E9H { near jmp }
  3833.         JE      @@1
  3834.         CMP     BYTE PTR [ECX],0EBH { short jmp }
  3835.         JNE     @@3
  3836.         MOVSX   EAX,AL
  3837.         INC     ECX
  3838.         INC     ECX
  3839.         JMP     @@2
  3840. @@1:
  3841.         ADD     ECX,5
  3842. @@2:
  3843.         ADD     ECX,EAX
  3844. @@3:
  3845. end;
  3846.  
  3847. { Notify debugger of a finally during an exception unwind }
  3848. procedure       NotifyExceptFinally;
  3849. asm
  3850.         CMP     BYTE PTR DebugHook,1
  3851.         JBE     @@1
  3852.         PUSH    EAX
  3853.         PUSH    EDX
  3854.         PUSH    ECX
  3855.         CALL    CheckJmp
  3856.         PUSH    ECX
  3857.         PUSH    ESP                     { pass pointer to arguments }
  3858.         PUSH    1                       { there is 1 argument }
  3859.         PUSH    cContinuable            { continuable execution }
  3860.         PUSH    cDelphiFinally          { our magic exception code }
  3861.         CALL    RaiseException
  3862.         POP     ECX
  3863.         POP     ECX
  3864.         POP     EDX
  3865.         POP     EAX
  3866. @@1:
  3867. end;
  3868.  
  3869.  
  3870. { Tell the debugger that the current exception is handled and cleaned up.
  3871.   Also indicate where execution is about to resume. }
  3872. procedure       NotifyTerminate;
  3873. asm
  3874.         CMP     BYTE PTR DebugHook,1
  3875.         JBE     @@1
  3876.         PUSH    EDX
  3877.         PUSH    ESP
  3878.         PUSH    1
  3879.         PUSH    cContinuable
  3880.         PUSH    cDelphiTerminate        { our magic exception code }
  3881.         CALL    RaiseException
  3882.         POP     EDX
  3883. @@1:
  3884. end;
  3885.  
  3886. { Tell the debugger that there was no handler found for the current execption
  3887.   and we are about to go to the default handler }
  3888. procedure       NotifyUnhandled;
  3889. asm
  3890.         PUSH    EAX
  3891.         PUSH    EDX
  3892.         CMP     BYTE PTR DebugHook,1
  3893.         JBE     @@1
  3894.         PUSH    ESP
  3895.         PUSH    2
  3896.         PUSH    cContinuable
  3897.         PUSH    cDelphiUnhandled
  3898.         CALL    RaiseException
  3899. @@1:
  3900.         POP     EDX
  3901.         POP     EAX
  3902. end;
  3903.  
  3904.  
  3905. procedure       _HandleAnyException;
  3906. asm
  3907.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  3908.         {       [ESP+ 8] errPtr: PExcFrame              }
  3909.         {       [ESP+12] ctxPtr: Pointer                }
  3910.         {       [ESP+16] dspPtr: Pointer                }
  3911.         { <-    EAX return value - always one   }
  3912.  
  3913.         MOV     EAX,[ESP+4]
  3914.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  3915.         JNE     @@exit
  3916.  
  3917.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  3918.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  3919.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  3920.         JE      @@DelphiException
  3921.         CLD
  3922.         CALL    _FpuInit
  3923.         MOV     EDX,ExceptObjProc
  3924.         TEST    EDX,EDX
  3925.         JE      @@exit
  3926.         CALL    EDX
  3927.         TEST    EAX,EAX
  3928.         JE      @@exit
  3929.         MOV     EDX,[ESP+12]
  3930.         CALL    NotifyNonDelphiException
  3931.         MOV     EDX,EAX
  3932.         MOV     EAX,[ESP+4]
  3933.         MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
  3934.  
  3935. @@DelphiException:
  3936.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  3937.  
  3938.         PUSH    EBX
  3939.         XOR     EBX,EBX
  3940.         PUSH    ESI
  3941.         PUSH    EDI
  3942.         PUSH    EBP
  3943.  
  3944.         MOV     EBX,FS:[EBX]
  3945.         PUSH    EBX                     { Save pointer to topmost frame }
  3946.         PUSH    EAX                     { Save OS exception pointer     }
  3947.         PUSH    EDX                     { Save exception object         }
  3948.         PUSH    ECX                     { Save exception address        }
  3949.  
  3950.         MOV     EDX,[ESP+8+8*4]
  3951.  
  3952.         PUSH    0
  3953.         PUSH    EAX
  3954.         PUSH    offset @@returnAddress
  3955.         PUSH    EDX
  3956.         CALL    RtlUnwind
  3957. @@returnAddress:
  3958.  
  3959.         MOV     EDI,[ESP+8+8*4]
  3960.  
  3961.         {       Make the RaiseList entry on the stack }
  3962.  
  3963.         CALL    SysInit.@GetTLS
  3964.         PUSH    [EAX].RaiseList
  3965.         MOV     [EAX].RaiseList,ESP
  3966.  
  3967.         MOV     EBP,[EDI].TExcFrame.hEBP
  3968.         MOV     EBX,[EDI].TExcFrame.desc
  3969.         MOV     [EDI].TExcFrame.desc,offset @@exceptFinally
  3970.  
  3971.         ADD     EBX,TExcDesc.instructions
  3972.         CALL    NotifyAnyExcept
  3973.         JMP     EBX
  3974.  
  3975. @@exceptFinally:
  3976.         JMP     _HandleFinally
  3977.  
  3978. @@destroyExcept:
  3979.         {       we come here if an exception handler has thrown yet another exception }
  3980.         {       we need to destroy the exception object and pop the raise list. }
  3981.  
  3982.         CALL    SysInit.@GetTLS
  3983.         MOV     ECX,[EAX].RaiseList
  3984.         MOV     EDX,[ECX].TRaiseFrame.NextRaise
  3985.         MOV     [EAX].RaiseList,EDX
  3986.  
  3987.         MOV     EAX,[ECX].TRaiseFrame.ExceptObject
  3988.         JMP     TObject.Free
  3989.  
  3990. @@exit:
  3991.         MOV     EAX,1
  3992. end;
  3993.  
  3994.  
  3995. procedure       _HandleOnException;
  3996. asm
  3997.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  3998.         {       [ESP+ 8] errPtr: PExcFrame              }
  3999.         {       [ESP+12] ctxPtr: Pointer                }
  4000.         {       [ESP+16] dspPtr: Pointer                }
  4001.         { <-    EAX return value - always one   }
  4002.  
  4003.         MOV     EAX,[ESP+4]
  4004.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4005.         JNE     @@exit
  4006.  
  4007.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4008.         JE      @@DelphiException
  4009.         CLD
  4010.         CALL    _FpuInit
  4011.         MOV     EDX,ExceptClsProc
  4012.         TEST    EDX,EDX
  4013.         JE      @@exit
  4014.         CALL    EDX
  4015.         TEST    EAX,EAX
  4016.         JNE     @@common
  4017.         JMP     @@exit
  4018.  
  4019. @@DelphiException:
  4020.         MOV     EAX,[EAX].TExceptionRecord.ExceptObject
  4021.         MOV     EAX,[EAX]                       { load vtable of exception object       }
  4022.  
  4023. @@common:
  4024.  
  4025.         MOV     EDX,[ESP+8]
  4026.  
  4027.         PUSH    EBX
  4028.         PUSH    ESI
  4029.         PUSH    EDI
  4030.         PUSH    EBP
  4031.  
  4032.         MOV     ECX,[EDX].TExcFrame.desc
  4033.         MOV     EBX,[ECX].TExcDesc.cnt
  4034.         LEA     ESI,[ECX].TExcDesc.excTab       { point ECX to exc descriptor table }
  4035.         MOV     EBP,EAX                         { load vtable of exception object }
  4036.  
  4037. @@innerLoop:
  4038.         MOV     EAX,[ESI].TExcDescEntry.vTable
  4039.         TEST    EAX,EAX                         { catch all clause?                     }
  4040.         JE      @@doHandler                     { yes: go execute handler               }
  4041.         MOV     EDI,EBP                         { load vtable of exception object       }
  4042.         JMP     @@haveVMT
  4043.  
  4044. @@vtLoop:
  4045.         MOV     EDI,[EDI]
  4046. @@haveVMT:
  4047.         MOV     EAX,[EAX]
  4048.         CMP     EAX,EDI
  4049.         JE      @@doHandler
  4050.  
  4051.         MOV     ECX,[EAX].vmtInstanceSize
  4052.         CMP     ECX,[EDI].vmtInstanceSize
  4053.         JNE     @@parent
  4054.  
  4055.         MOV     EAX,[EAX].vmtClassName
  4056.         MOV     EDX,[EDI].vmtClassName
  4057.  
  4058.         XOR     ECX,ECX
  4059.         MOV     CL,[EAX]
  4060.         CMP     CL,[EDX]
  4061.         JNE     @@parent
  4062.  
  4063.         INC     EAX
  4064.         INC     EDX
  4065.         CALL    _AStrCmp
  4066.         JE      @@doHandler
  4067.  
  4068. @@parent:
  4069.         MOV     EDI,[EDI].vmtParent             { load vtable of parent         }
  4070.         MOV     EAX,[ESI].TExcDescEntry.vTable
  4071.         TEST    EDI,EDI
  4072.         JNE     @@vtLoop
  4073.  
  4074.         ADD     ESI,8
  4075.         DEC     EBX
  4076.         JNZ     @@innerLoop
  4077.  
  4078.         POP     EBP
  4079.         POP     EDI
  4080.         POP     ESI
  4081.         POP     EBX
  4082.         JMP     @@exit
  4083.  
  4084. @@doHandler:
  4085.         MOV     EAX,[ESP+4+4*4]
  4086.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4087.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  4088.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  4089.         JE      @@haveObject
  4090.         CALL    ExceptObjProc
  4091.         MOV     EDX,[ESP+12+4*4]
  4092.         CALL    NotifyNonDelphiException
  4093.         MOV     EDX,EAX
  4094.         MOV     EAX,[ESP+4+4*4]
  4095.         MOV     ECX,[EAX].TExceptionRecord.ExceptionAddress
  4096.  
  4097. @@haveObject:
  4098.         XOR     EBX,EBX
  4099.         MOV     EBX,FS:[EBX]
  4100.         PUSH    EBX                     { Save topmost frame     }
  4101.         PUSH    EAX                     { Save exception record  }
  4102.         PUSH    EDX                     { Save exception object  }
  4103.         PUSH    ECX                     { Save exception address }
  4104.  
  4105.         MOV     EDX,[ESP+8+8*4]
  4106.         OR      [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
  4107.  
  4108.         PUSH    ESI                     { Save handler entry     }
  4109.  
  4110.         PUSH    0
  4111.         PUSH    EAX
  4112.         PUSH    offset @@returnAddress
  4113.         PUSH    EDX
  4114.         CALL    RtlUnwind
  4115. @@returnAddress:
  4116.  
  4117.         POP     EBX                     { Restore handler entry  }
  4118.  
  4119.         MOV     EDI,[ESP+8+8*4]
  4120.  
  4121.         {       Make the RaiseList entry on the stack }
  4122.  
  4123.         CALL    SysInit.@GetTLS
  4124.         PUSH    [EAX].RaiseList
  4125.         MOV     [EAX].RaiseList,ESP
  4126.  
  4127.         MOV     EBP,[EDI].TExcFrame.hEBP
  4128.         MOV     [EDI].TExcFrame.desc,offset @@exceptFinally
  4129.         MOV     EAX,[ESP].TRaiseFrame.ExceptObject
  4130.         CALL    NotifyOnExcept
  4131.         JMP     [EBX].TExcDescEntry.handler
  4132.  
  4133. @@exceptFinally:
  4134.         JMP     _HandleFinally
  4135. @@destroyExcept:
  4136.         {       we come here if an exception handler has thrown yet another exception }
  4137.         {       we need to destroy the exception object and pop the raise list. }
  4138.  
  4139.         CALL    SysInit.@GetTLS
  4140.         MOV     ECX,[EAX].RaiseList
  4141.         MOV     EDX,[ECX].TRaiseFrame.NextRaise
  4142.         MOV     [EAX].RaiseList,EDX
  4143.  
  4144.         MOV     EAX,[ECX].TRaiseFrame.ExceptObject
  4145.         JMP     TObject.Free
  4146. @@exit:
  4147.         MOV     EAX,1
  4148. end;
  4149.  
  4150.  
  4151. procedure       _HandleFinally;
  4152. asm
  4153.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  4154.         {       [ESP+ 8] errPtr: PExcFrame              }
  4155.         {       [ESP+12] ctxPtr: Pointer                }
  4156.         {       [ESP+16] dspPtr: Pointer                }
  4157.         { <-    EAX return value - always one   }
  4158.  
  4159.         MOV     EAX,[ESP+4]
  4160.         MOV     EDX,[ESP+8]
  4161.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4162.         JE      @@exit
  4163.         MOV     ECX,[EDX].TExcFrame.desc
  4164.         MOV     [EDX].TExcFrame.desc,offset @@exit
  4165.  
  4166.         PUSH    EBX
  4167.         PUSH    ESI
  4168.         PUSH    EDI
  4169.         PUSH    EBP
  4170.  
  4171.         MOV     EBP,[EDX].TExcFrame.hEBP
  4172.         ADD     ECX,TExcDesc.instructions
  4173.         CALL    NotifyExceptFinally
  4174.         CALL    ECX
  4175.  
  4176.         POP     EBP
  4177.         POP     EDI
  4178.         POP     ESI
  4179.         POP     EBX
  4180.  
  4181. @@exit:
  4182.         MOV     EAX,1
  4183. end;
  4184.  
  4185.  
  4186. procedure       _HandleAutoException;
  4187. asm
  4188.         { ->    [ESP+ 4] excPtr: PExceptionRecord       }
  4189.         {       [ESP+ 8] errPtr: PExcFrame              }
  4190.         {       [ESP+12] ctxPtr: Pointer                }
  4191.         {       [ESP+16] dspPtr: Pointer                }
  4192.         { <-    EAX return value - always one           }
  4193.  
  4194.         MOV     EAX,[ESP+4]
  4195.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4196.         JNE     @@exit
  4197.  
  4198.         MOV     EBX,8000FFFFH
  4199.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4200.         JNE     @@done
  4201.  
  4202.         MOV     EDX,[EAX].TExceptionRecord.ExceptObject
  4203.         MOV     ECX,[EAX].TExceptionRecord.ExceptAddr
  4204.         MOV     EAX,[ESP+8]
  4205.         MOV     EAX,[EAX].TExcFrame.SelfOfMethod
  4206.         MOV     EBX,[EAX]
  4207.         CALL    [EBX].vmtSafeCallException.Pointer
  4208.         MOV     EBX,EAX
  4209. @@done:
  4210.         XOR     EAX,EAX
  4211.         MOV     ESP,[ESP+8]
  4212.         POP     ECX
  4213.         MOV     FS:[EAX],ECX
  4214.         POP     EDX
  4215.         POP     EBP
  4216.         LEA     EDX,[EDX].TExcDesc.instructions
  4217.         POP     ECX
  4218.         JMP     EDX
  4219. @@exit:
  4220.         MOV     EAX,1
  4221. end;
  4222.  
  4223.  
  4224. procedure       _RaiseExcept;
  4225. asm
  4226.         { ->    EAX     Pointer to exception object     }
  4227.         {       [ESP]   Error address           }
  4228.  
  4229.         POP     EDX
  4230.  
  4231.         PUSH    ESP
  4232.         PUSH    EBP
  4233.         PUSH    EDI
  4234.         PUSH    ESI
  4235.         PUSH    EBX
  4236.         PUSH    EAX                             { pass class argument           }
  4237.         PUSH    EDX                             { pass address argument         }
  4238.  
  4239.         PUSH    ESP                             { pass pointer to arguments             }
  4240.         PUSH    7                               { there are seven arguments               }
  4241.         PUSH    cNonContinuable                 { we can't continue execution   }
  4242.         PUSH    cDelphiException                { our magic exception code              }
  4243.         PUSH    EDX                             { pass the user's return address        }
  4244.         JMP     RaiseException
  4245. end;
  4246.  
  4247.  
  4248. procedure       _RaiseAgain;
  4249. asm
  4250.         { ->    [ESP        ] return address to user program }
  4251.         {       [ESP+ 4     ] raise list entry (4 dwords)    }
  4252.         {       [ESP+ 4+ 4*4] saved topmost frame            }
  4253.         {       [ESP+ 4+ 5*4] saved registers (4 dwords)     }
  4254.         {       [ESP+ 4+ 9*4] return address to OS           }
  4255.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  4256.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  4257.  
  4258.         { Point the error handler of the exception frame to something harmless }
  4259.  
  4260.         MOV     EAX,[ESP+8+10*4]
  4261.         MOV     [EAX].TExcFrame.desc,offset @@exit
  4262.  
  4263.         { Pop the RaiseList }
  4264.  
  4265.         CALL    SysInit.@GetTLS
  4266.         MOV     EDX,[EAX].RaiseList
  4267.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  4268.         MOV     [EAX].RaiseList,ECX
  4269.  
  4270.         { Destroy any objects created for non-delphi exceptions }
  4271.  
  4272.         MOV     EAX,[EDX].TRaiseFrame.ExceptionRecord
  4273.         AND     [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding
  4274.         CMP     [EAX].TExceptionRecord.ExceptionCode,cDelphiException
  4275.         JE      @@delphiException
  4276.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  4277.         CALL    TObject.Free
  4278.         CALL    NotifyReRaise
  4279.  
  4280. @@delphiException:
  4281.  
  4282.         XOR     EAX,EAX
  4283.         ADD     ESP,5*4
  4284.         MOV     EDX,FS:[EAX]
  4285.         POP     ECX
  4286.         MOV     EDX,[EDX].TExcFrame.next
  4287.         MOV     [ECX].TExcFrame.next,EDX
  4288.  
  4289.         POP     EBP
  4290.         POP     EDI
  4291.         POP     ESI
  4292.         POP     EBX
  4293. @@exit:
  4294.         MOV     EAX,1
  4295. end;
  4296.  
  4297.  
  4298. procedure       _DoneExcept;
  4299. asm
  4300.         { ->    [ESP+ 4+10*4] excPtr: PExceptionRecord       }
  4301.         {       [ESP+ 8+10*4] errPtr: PExcFrame              }
  4302.  
  4303.         { Pop the RaiseList }
  4304.  
  4305.         CALL    SysInit.@GetTLS
  4306.         MOV     EDX,[EAX].RaiseList
  4307.         MOV     ECX,[EDX].TRaiseFrame.NextRaise
  4308.         MOV     [EAX].RaiseList,ECX
  4309.  
  4310.         { Destroy exception object }
  4311.  
  4312.         MOV     EAX,[EDX].TRaiseFrame.ExceptObject
  4313.         CALL    TObject.Free
  4314.  
  4315.         POP     EDX
  4316.         MOV     ESP,[ESP+8+9*4]
  4317.         XOR     EAX,EAX
  4318.         POP     ECX
  4319.         MOV     FS:[EAX],ECX
  4320.         POP     EAX
  4321.         POP     EBP
  4322.         CALL    NotifyTerminate
  4323.         JMP     EDX
  4324. end;
  4325.  
  4326.  
  4327. procedure   _TryFinallyExit;
  4328. asm
  4329.         XOR     EDX,EDX
  4330.         MOV     ECX,[ESP+4].TExcFrame.desc
  4331.         MOV     EAX,[ESP+4].TExcFrame.next
  4332.         ADD     ECX,TExcDesc.instructions
  4333.         MOV     FS:[EDX],EAX
  4334.         CALL    ECX
  4335. @@1:    RET     12
  4336. end;
  4337.  
  4338.  
  4339. type
  4340.   PInitContext = ^TInitContext;
  4341.   TInitContext = record
  4342.     OuterContext: PInitContext;     { saved InitContext   }
  4343.     ExcFrame:     PExcFrame;        { bottom exc handler  }
  4344.     InitTable:    PackageInfo;      { unit init info      }
  4345.     InitCount:    Integer;          { how far we got      }
  4346.     Module:       PLibModule;       { ptr to module desc  }
  4347.     DLLSaveEBP:   Pointer;          { saved regs for DLLs }
  4348.     DLLSaveEBX:   Pointer;          { saved regs for DLLs }
  4349.     DLLSaveESI:   Pointer;          { saved regs for DLLs }
  4350.     DLLSaveEDI:   Pointer;          { saved regs for DLLs }
  4351.     DLLInitState: Byte;
  4352.   end;
  4353.  
  4354. var
  4355.   InitContext: TInitContext;
  4356.  
  4357.  
  4358. procedure       RunErrorAt(ErrCode: Integer; ErrorAddr: Pointer);
  4359. asm
  4360.         MOV     [ESP],ErrorAddr
  4361.         JMP     _RunError
  4362. end;
  4363.  
  4364. procedure       MapToRunError(P: PExceptionRecord); stdcall;
  4365. const
  4366.   STATUS_ACCESS_VIOLATION         = $C0000005;
  4367.   STATUS_ARRAY_BOUNDS_EXCEEDED    = $C000008C;
  4368.   STATUS_FLOAT_DENORMAL_OPERAND   = $C000008D;
  4369.   STATUS_FLOAT_DIVIDE_BY_ZERO     = $C000008E;
  4370.   STATUS_FLOAT_INEXACT_RESULT     = $C000008F;
  4371.   STATUS_FLOAT_INVALID_OPERATION  = $C0000090;
  4372.   STATUS_FLOAT_OVERFLOW           = $C0000091;
  4373.   STATUS_FLOAT_STACK_CHECK        = $C0000092;
  4374.   STATUS_FLOAT_UNDERFLOW          = $C0000093;
  4375.   STATUS_INTEGER_DIVIDE_BY_ZERO   = $C0000094;
  4376.   STATUS_INTEGER_OVERFLOW         = $C0000095;
  4377.   STATUS_PRIVILEGED_INSTRUCTION   = $C0000096;
  4378.   STATUS_STACK_OVERFLOW           = $C00000FD;
  4379.   STATUS_CONTROL_C_EXIT           = $C000013A;
  4380. var
  4381.   ErrCode: Byte;
  4382. begin
  4383.   case P.ExceptionCode of
  4384.     STATUS_INTEGER_DIVIDE_BY_ZERO:  ErrCode := 200;
  4385.     STATUS_ARRAY_BOUNDS_EXCEEDED:   ErrCode := 201;
  4386.     STATUS_FLOAT_OVERFLOW:          ErrCode := 205;
  4387.     STATUS_FLOAT_INEXACT_RESULT,
  4388.     STATUS_FLOAT_INVALID_OPERATION,
  4389.     STATUS_FLOAT_STACK_CHECK:       ErrCode := 207;
  4390.     STATUS_FLOAT_DIVIDE_BY_ZERO:    ErrCode := 200;
  4391.     STATUS_INTEGER_OVERFLOW:        ErrCode := 215;
  4392.     STATUS_FLOAT_UNDERFLOW,
  4393.     STATUS_FLOAT_DENORMAL_OPERAND:  ErrCode := 206;
  4394.     STATUS_ACCESS_VIOLATION:        ErrCode := 216;
  4395.     STATUS_PRIVILEGED_INSTRUCTION:  ErrCode := 218;
  4396.     STATUS_CONTROL_C_EXIT:          ErrCode := 217;
  4397.     STATUS_STACK_OVERFLOW:          ErrCode := 202;
  4398.   else                              ErrCode := 217;
  4399.   end;
  4400.   RunErrorAt(ErrCode, P.ExceptionAddress);
  4401. end;
  4402.  
  4403. procedure       _ExceptionHandler;
  4404. asm
  4405.         MOV     EAX,[ESP+4]
  4406.  
  4407.         TEST    [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
  4408.         JNE     @@exit
  4409.         CLD
  4410.         CALL    _FpuInit
  4411.         MOV     EDX,[ESP+8]
  4412.  
  4413.         PUSH    0
  4414.         PUSH    EAX
  4415.         PUSH    offset @@returnAddress
  4416.         PUSH    EDX
  4417.         CALL    RtlUnwind
  4418. @@returnAddress:
  4419.  
  4420.         MOV     EBX,[ESP+4]
  4421.         CMP     [EBX].TExceptionRecord.ExceptionCode,cDelphiException
  4422.         MOV     EDX,[EBX].TExceptionRecord.ExceptAddr
  4423.         MOV     EAX,[EBX].TExceptionRecord.ExceptObject
  4424.         JE      @@DelphiException2
  4425.  
  4426.         MOV     EDX,ExceptObjProc
  4427.         TEST    EDX,EDX
  4428.         JE      MapToRunError
  4429.         MOV     EAX,EBX
  4430.         CALL    EDX
  4431.         TEST    EAX,EAX
  4432.         JE      MapToRunError
  4433.         MOV     EDX,[EBX].TExceptionRecord.ExceptionAddress
  4434.  
  4435. @@DelphiException2:
  4436.  
  4437.         CALL    NotifyUnhandled
  4438.         MOV     ECX,ExceptProc
  4439.         TEST    ECX,ECX
  4440.         JE      @@noExceptProc
  4441.         CALL    ECX             { call ExceptProc(ExceptObject, ExceptAddr) }
  4442.  
  4443. @@noExceptProc:
  4444.         MOV     ECX,[ESP+4]
  4445.         MOV     EAX,217
  4446.         MOV     EDX,[ECX].TExceptionRecord.ExceptAddr
  4447.         MOV     [ESP],EDX
  4448.         JMP     _RunError
  4449.  
  4450. @@exit:
  4451.         XOR     EAX,EAX
  4452. end;
  4453.  
  4454.  
  4455. procedure       SetExceptionHandler;
  4456. asm
  4457.         XOR     EDX,EDX                 { using [EDX] saves some space over [0] }
  4458.         LEA     EAX,[EBP-12]
  4459.         MOV     ECX,FS:[EDX]            { ECX := head of chain                  }
  4460.         MOV     FS:[EDX],EAX            { head of chain := @exRegRec            }
  4461.  
  4462.         MOV     [EAX].TExcFrame.next,ECX
  4463.         MOV     [EAX].TExcFrame.desc,offset _ExceptionHandler
  4464.         MOV     [EAX].TExcFrame.hEBP,EBP
  4465.         MOV     InitContext.ExcFrame,EAX
  4466. end;
  4467.  
  4468.  
  4469. procedure       UnsetExceptionHandler;
  4470. asm
  4471.         XOR     EDX,EDX
  4472.         MOV     EAX,InitContext.ExcFrame
  4473.         MOV     ECX,FS:[EDX]    { ECX := head of chain          }
  4474.         CMP     EAX,ECX         { simple case: our record is first      }
  4475.         JNE     @@search
  4476.         MOV     EAX,[EAX]       { head of chain := exRegRec.next        }
  4477.         MOV     FS:[EDX],EAX
  4478.         JMP     @@exit
  4479.  
  4480. @@loop:
  4481.         MOV     ECX,[ECX]
  4482. @@search:
  4483.         CMP     ECX,-1          { at end of list?                       }
  4484.         JE      @@exit          { yes - didn't find it          }
  4485.         CMP     [ECX],EAX       { is it the next one on the list?       }
  4486.         JNE     @@loop          { no - look at next one on list }
  4487. @@unlink:                       { yes - unlink our record               }
  4488.         MOV     EAX,[EAX]       { get next record on list               }
  4489.         MOV     [ECX],EAX       { unlink our record                     }
  4490. @@exit:
  4491. end;
  4492.  
  4493.  
  4494. procedure FInitUnits;
  4495. var
  4496.   Count: Integer;
  4497.   Table: PUnitEntryTable;
  4498.   P: procedure;
  4499. begin
  4500.   if InitContext.InitTable = nil then
  4501.         exit;
  4502.   Count := InitContext.InitCount;
  4503.   Table := InitContext.InitTable^.UnitInfo;
  4504.   try
  4505.     while Count > 0 do
  4506.     begin
  4507.       Dec(Count);
  4508.       InitContext.InitCount := Count;
  4509.       P := Table^[Count].FInit;
  4510.       if Assigned(P) then
  4511.         P;
  4512.     end;
  4513.   except
  4514.     FInitUnits;  { try to finalize the others }
  4515.     raise;
  4516.   end;
  4517. end;
  4518.  
  4519.  
  4520. procedure InitUnits;
  4521. var
  4522.   Count, I: Integer;
  4523.   Table: PUnitEntryTable;
  4524.   P: procedure;
  4525. begin
  4526.   if InitContext.InitTable = nil then
  4527.         exit;
  4528.   Count := InitContext.InitTable^.UnitCount;
  4529.   I := 0;
  4530.   Table := InitContext.InitTable^.UnitInfo;
  4531.   try
  4532.     while I < Count do
  4533.     begin
  4534.       P := Table^[I].Init;
  4535.       Inc(I);
  4536.       InitContext.InitCount := I;
  4537.       if Assigned(P) then
  4538.         P;
  4539.     end;
  4540.   except
  4541.     FInitUnits;
  4542.     raise;
  4543.   end;
  4544. end;
  4545.  
  4546.  
  4547. procedure _PackageLoad(const Table : PackageInfo);
  4548. var
  4549.   SavedContext: TInitContext;
  4550. begin
  4551.   SavedContext := InitContext;
  4552.   InitContext.DLLInitState := 0;
  4553.   InitContext.InitTable := Table;
  4554.   InitContext.InitCount := 0;
  4555.   InitContext.OuterContext := @SavedContext;
  4556.   try
  4557.     InitUnits;
  4558.   finally
  4559.     InitContext := SavedContext;
  4560.   end;
  4561. end;
  4562.  
  4563.  
  4564. procedure _PackageUnload(const Table : PackageInfo);
  4565. var
  4566.   SavedContext: TInitContext;
  4567. begin
  4568.   SavedContext := InitContext;
  4569.   InitContext.DLLInitState := 0;
  4570.   InitContext.InitTable := Table;
  4571.   InitContext.InitCount := Table^.UnitCount;
  4572.   InitContext.OuterContext := @SavedContext;
  4573.   try
  4574.     FInitUnits;
  4575.   finally
  4576.     InitContext := SavedContext;
  4577.   end;
  4578. end;
  4579.  
  4580.  
  4581. procedure       _StartExe;
  4582. asm
  4583.         { ->    EAX InitTable   }
  4584.         {       EDX Module      }
  4585.         MOV     InitContext.InitTable,EAX
  4586.         XOR     EAX,EAX
  4587.         MOV     InitContext.InitCount,EAX
  4588.         MOV     InitContext.Module,EDX
  4589.         MOV     EAX,[EDX].TLibModule.Instance
  4590.         MOV     MainInstance,EAX
  4591.  
  4592.         CALL    SetExceptionHandler
  4593.  
  4594.         MOV     IsLibrary,0
  4595.  
  4596.         CALL    InitUnits;
  4597. end;
  4598.  
  4599.  
  4600. procedure       _StartLib;
  4601. asm
  4602.         { ->    EAX InitTable   }
  4603.         {       EDX Module      }
  4604.         {       ECX InitTLS     }
  4605.         {       [ESP+4] DllProc }
  4606.         {       [EBP+8] HInst   }
  4607.         {       [EBP+12] Reason }
  4608.  
  4609.         { Push some desperately needed registers }
  4610.  
  4611.         PUSH    ECX
  4612.         PUSH    ESI
  4613.         PUSH    EDI
  4614.  
  4615.         { Save the current init context into the stackframe of our caller }
  4616.  
  4617.         MOV     ESI,offset InitContext
  4618.         LEA     EDI,[EBP- (type TExcFrame) - (type TInitContext)]
  4619.         MOV     ECX,(type TInitContext)/4
  4620.         REP     MOVSD
  4621.  
  4622.         { Setup the current InitContext }
  4623.  
  4624.         POP     InitContext.DLLSaveEDI
  4625.         POP     InitContext.DLLSaveESI
  4626.         MOV     InitContext.DLLSaveEBP,EBP
  4627.         MOV     InitContext.DLLSaveEBX,EBX
  4628.         MOV     InitContext.InitTable,EAX
  4629.         MOV     InitContext.Module,EDX
  4630.         LEA     ECX,[EBP- (type TExcFrame) - (type TInitContext)]
  4631.         MOV     InitContext.OuterContext,ECX
  4632.         XOR     ECX,ECX
  4633.         CMP     dword ptr [EBP+12],0
  4634.         JNE     @@notShutDown
  4635.         MOV     ECX,[EAX].PackageInfoTable.UnitCount
  4636. @@notShutDown:
  4637.         MOV     InitContext.InitCount,ECX
  4638.  
  4639.         CALL    SetExceptionHandler
  4640.  
  4641.         MOV     EAX,[EBP+12]
  4642.         INC     EAX
  4643.         MOV     InitContext.DLLInitState,AL
  4644.         DEC     EAX
  4645.  
  4646.         { Init any needed TLS }
  4647.  
  4648.         POP     ECX
  4649.         CALL    dword ptr [ECX+EAX*4]
  4650.  
  4651.         { Call any DllProc }
  4652.  
  4653.         MOV     EDX,[ESP+4]
  4654.         TEST    EDX,EDX
  4655.         JE      @@noDllProc
  4656.         MOV     EAX,[EBP+12]
  4657.         CALL    EDX
  4658. @@noDllProc:
  4659.  
  4660.         { Set IsLibrary if there was no exe yet }
  4661.  
  4662.         CMP     MainInstance,0
  4663.         JNE     @@haveExe
  4664.         MOV     IsLibrary,1
  4665. @@haveExe:
  4666.  
  4667.         MOV     EAX,[EBP+12]
  4668.         DEC     EAX
  4669.         JNE     _Halt0
  4670.         CALL    InitUnits
  4671.         RET     4
  4672. end;
  4673.  
  4674.  
  4675. procedure _InitResStrings;
  4676. asm
  4677.         { ->    EAX     Pointer to init table               }
  4678.         {                 record                            }
  4679.         {                   cnt: Integer;                   }
  4680.         {                   tab: array [1..cnt] record      }
  4681.         {                      variableAddress: Pointer;    }
  4682.         {                      resStringAddress: Pointer;   }
  4683.         {                   end;                            }
  4684.         {                 end;                              }
  4685.  
  4686.         PUSH    EBX
  4687.         PUSH    ESI
  4688.         MOV     EBX,[EAX]
  4689.         LEA     ESI,[EAX+4]
  4690. @@loop:
  4691.         MOV     EAX,[ESI+4]
  4692.         MOV     EDX,[ESI]
  4693.         CALL    LoadResString
  4694.         ADD     ESI,8
  4695.         DEC     EBX
  4696.         JNZ     @@loop
  4697.  
  4698.         POP     ESI
  4699.         POP     EBX
  4700. end;
  4701.  
  4702. var
  4703.   runErrMsg: array[0..29] of Char = 'Runtime error     at 00000000'#0;
  4704.                         // columns:  0123456789012345678901234567890
  4705.   errCaption: array[0..5] of Char = 'Error'#0;
  4706.  
  4707.  
  4708. procedure MakeErrorMessage;
  4709. const
  4710.   dig : array [0..15] of Char = '0123456789ABCDEF';
  4711. asm
  4712.         PUSH    EBX
  4713.         MOV     EAX,ExitCode
  4714.         MOV     EBX,offset runErrMsg + 16
  4715.         MOV     ECX,10
  4716.  
  4717. @@digLoop:
  4718.         XOR     EDX,EDX
  4719.         DIV     ECX
  4720.         ADD     DL,'0'
  4721.         MOV     [EBX],DL
  4722.         DEC     EBX
  4723.         TEST    EAX,EAX
  4724.         JNZ     @@digLoop
  4725.  
  4726.         MOV     EAX,ErrorAddr
  4727.  
  4728.         CALL    FindHInstance
  4729.         MOV     EDX, ErrorAddr
  4730.         XCHG    EAX, EDX
  4731.         SUB     EAX, EDX           { EAX <=> offset from start of code for HINSTANCE }
  4732.         MOV     EBX,offset runErrMsg + 28
  4733.                 
  4734. @@hdigLoop:
  4735.         MOV     EDX,EAX
  4736.         AND     EDX,0FH
  4737.         MOV     DL,byte ptr dig[EDX]
  4738.         MOV     [EBX],DL
  4739.         DEC     EBX
  4740.         SHR     EAX,4
  4741.         JNE     @@hdigLoop
  4742.         POP     EBX
  4743. end;
  4744.  
  4745.  
  4746. procedure       ExitDll;
  4747. asm
  4748.         { Restore the InitContext }
  4749.  
  4750.         MOV     EDI,offset InitContext
  4751.  
  4752.         MOV     EBX,InitContext.DLLSaveEBX
  4753.         MOV     EBP,InitContext.DLLSaveEBP
  4754.         PUSH    [EDI].TInitContext.DLLSaveESI
  4755.         PUSH    [EDI].TInitContext.DLLSaveEDI
  4756.  
  4757.         MOV     ESI,[EDI].TInitContext.OuterContext
  4758.         MOV     ECX,(type TInitContext)/4
  4759.         REP     MOVSD
  4760.         POP     EDI
  4761.         POP     ESI
  4762.  
  4763.         { Return False if ExitCode <> 0, and set ExitCode to 0 }
  4764.  
  4765.         XOR     EAX,EAX
  4766.         XCHG    EAX,ExitCode
  4767.         NEG     EAX
  4768.         SBB     EAX,EAX
  4769.         INC     EAX
  4770.         LEAVE
  4771.         RET     12
  4772. end;
  4773.  
  4774.  
  4775. procedure _Halt0;
  4776. var
  4777.   P: procedure;
  4778. begin
  4779.  
  4780.   if InitContext.DLLInitState = 0 then
  4781.     while ExitProc <> nil do
  4782.     begin
  4783.       @P := ExitProc;
  4784.       ExitProc := nil;
  4785.       P;
  4786.     end;
  4787.  
  4788.   { If there was some kind of runtime error, alert the user }
  4789.  
  4790.   if ErrorAddr <> nil then
  4791.   begin
  4792.     MakeErrorMessage;
  4793.     if IsConsole then
  4794.       WriteLn(PChar(@runErrMsg))
  4795.     else
  4796.       MessageBox(0, runErrMsg, errCaption, 0);
  4797.     ErrorAddr := nil;
  4798.   end;
  4799.  
  4800.   { This loop exists because we might be nested in PackageLoad calls when }
  4801.   { Halt got called. We need to unwind these contexts.                    }
  4802.  
  4803.   while True do
  4804.   begin
  4805.  
  4806.     { If we are a library, and we are starting up fine, there are no units to finalize }
  4807.  
  4808.     if (InitContext.DLLInitState = 2) and (ExitCode = 0) then
  4809.       InitContext.InitCount := 0;
  4810.  
  4811.     { Undo any unit initializations accomplished so far }
  4812.  
  4813.     FInitUnits;
  4814.  
  4815.     if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then
  4816.       if InitContext.Module <> nil then
  4817.         with InitContext do
  4818.         begin
  4819.           UnregisterModule(Module);
  4820.           if Module.ResInstance <> Module.Instance then
  4821.             FreeLibrary(Module.ResInstance);
  4822.         end;
  4823.  
  4824.     UnsetExceptionHandler;
  4825.  
  4826.     if InitContext.DllInitState <> 0 then
  4827.       ExitDll;
  4828.  
  4829.     if InitContext.OuterContext = nil then
  4830.       ExitProcess(ExitCode);
  4831.  
  4832.     InitContext := InitContext.OuterContext^
  4833.   end;
  4834.  
  4835.   asm
  4836.     db 'Portions Copyright (c) 1983,96 Borland',0
  4837.   end;
  4838.  
  4839. end;
  4840.  
  4841.  
  4842. procedure _Halt;
  4843. asm
  4844.         MOV     ExitCode,EAX
  4845.         JMP     _Halt0
  4846. end;
  4847.  
  4848.  
  4849. procedure _Run0Error;
  4850. asm
  4851.         XOR     EAX,EAX
  4852.         JMP     _RunError
  4853. end;
  4854.  
  4855.  
  4856. procedure _RunError;
  4857. asm
  4858.         POP     ErrorAddr
  4859.         JMP     _Halt
  4860. end;
  4861.  
  4862.  
  4863. procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
  4864. asm
  4865.         CMP     AssertErrorProc,0
  4866.         JE      @@1
  4867.         PUSH    [ESP].Pointer
  4868.         CALL    AssertErrorProc
  4869. @@1:    MOV     AL,reAssertionFailed
  4870.         JMP     Error
  4871. end;
  4872.  
  4873.  
  4874. type
  4875.   PThreadRec = ^TThreadRec;
  4876.   TThreadRec = record
  4877.     Func: TThreadFunc;
  4878.     Parameter: Pointer;
  4879.   end;
  4880.  
  4881.  
  4882. function ThreadWrapper(Parameter: Pointer): Integer; stdcall;
  4883. asm
  4884.         CALL    _FpuInit
  4885.         XOR     ECX,ECX
  4886.         PUSH    EBP
  4887.         PUSH    offset _ExceptionHandler
  4888.         MOV     EDX,FS:[ECX]
  4889.         PUSH    EDX
  4890.         MOV     EAX,Parameter
  4891.         MOV     FS:[ECX],ESP
  4892.  
  4893.         MOV     ECX,[EAX].TThreadRec.Parameter
  4894.         MOV     EDX,[EAX].TThreadRec.Func
  4895.         PUSH    ECX
  4896.         PUSH    EDX
  4897.         CALL    _FreeMem
  4898.         POP     EDX
  4899.         POP     EAX
  4900.         CALL    EDX
  4901.  
  4902.         XOR     EDX,EDX
  4903.         POP     ECX
  4904.         MOV     FS:[EDX],ECX
  4905.         POP     ECX
  4906.         POP     EBP
  4907. end;
  4908.  
  4909.  
  4910. function BeginThread(SecurityAttributes: Pointer; StackSize: Integer;
  4911.                      ThreadFunc: TThreadFunc; Parameter: Pointer;
  4912.                      CreationFlags: Integer; var ThreadId: Integer): Integer;
  4913. var
  4914.   P: PThreadRec;
  4915. begin
  4916.   New(P);
  4917.   P.Func := ThreadFunc;
  4918.   P.Parameter := Parameter;
  4919.   IsMultiThread := TRUE;
  4920.   result := CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P,
  4921.                          CreationFlags, ThreadID);
  4922. end;
  4923.  
  4924.  
  4925. procedure EndThread(ExitCode: Integer);
  4926. begin
  4927.   ExitThread(ExitCode);
  4928. end;
  4929.  
  4930.  
  4931. type
  4932.         StrRec = record
  4933.         allocSiz:       Longint;
  4934.         refCnt: Longint;
  4935.         length: Longint;
  4936.         end;
  4937.  
  4938. const
  4939.         skew = sizeof(StrRec);
  4940.         rOff = sizeof(StrRec) - sizeof(Longint);
  4941.         overHead = sizeof(StrRec) + 1;
  4942.  
  4943.  
  4944. procedure _LStrClr(var S: AnsiString);
  4945. asm
  4946.         { ->    EAX pointer to str      }
  4947.  
  4948.         MOV     EDX,[EAX]                       { fetch str                     }
  4949.         TEST    EDX,EDX                         { if nil, nothing to do         }
  4950.         JE      @@done
  4951.         MOV     dword ptr [EAX],0               { clear str                     }
  4952.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  4953.         DEC     ECX                             { if < 0: literal str           }
  4954.         JL      @@done
  4955.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
  4956.         JNE     @@done
  4957.         PUSH    EAX
  4958.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  4959.         CALL    _FreeMem
  4960.         POP     EAX
  4961. @@done:
  4962. end;
  4963.  
  4964.  
  4965. procedure       _LStrArrayClr{var str: AnsiString; cnt: longint};
  4966. asm
  4967.         { ->    EAX pointer to str      }
  4968.         {       EDX cnt         }
  4969.  
  4970.         PUSH    EBX
  4971.         PUSH    ESI
  4972.         MOV     EBX,EAX
  4973.         MOV     ESI,EDX
  4974.  
  4975. @@loop:
  4976.         MOV     EDX,[EBX]                       { fetch str                     }
  4977.         TEST    EDX,EDX                         { if nil, nothing to do         }
  4978.         JE      @@doneEntry
  4979.         MOV     dword ptr [EBX],0               { clear str                     }
  4980.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
  4981.         DEC     ECX                             { if < 0: literal str           }
  4982.         JL      @@doneEntry
  4983.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back           }
  4984.         JNE     @@doneEntry
  4985.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  4986.         CALL    _FreeMem
  4987. @@doneEntry:
  4988.         ADD     EBX,4
  4989.         DEC     ESI
  4990.         JNE     @@loop
  4991.  
  4992.         POP     ESI
  4993.         POP     EBX
  4994. end;
  4995.  
  4996. procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
  4997. asm
  4998.         TEST    EDX,EDX
  4999.         JE      @@2
  5000.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5001.         INC     ECX
  5002.         JG      @@1
  5003.         PUSH    EAX
  5004.         PUSH    EDX
  5005.         MOV     EAX,[EDX-skew].StrRec.length
  5006.         CALL    _NewAnsiString
  5007.         MOV     EDX,EAX
  5008.         POP     EAX
  5009.         PUSH    EDX
  5010.         MOV     ECX,[EAX-skew].StrRec.length
  5011.         CALL    Move
  5012.         POP     EDX
  5013.         POP     EAX
  5014.         JMP     @@2
  5015. @@1:    MOV     [EDX-skew].StrRec.refCnt,ECX
  5016. @@2:    XCHG    EDX,[EAX]
  5017.         TEST    EDX,EDX
  5018.         JE      @@3
  5019.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5020.         DEC     ECX
  5021.         JL      @@3
  5022.         MOV     [EDX-skew].StrRec.refCnt,ECX
  5023.         JNE     @@3
  5024.         LEA     EAX,[EDX-skew].StrRec.refCnt
  5025.         CALL    _FreeMem
  5026. @@3:
  5027. end;
  5028.  
  5029. procedure       _LStrLAsg{var dest: AnsiString; source: AnsiString};
  5030. asm
  5031. { ->    EAX     pointer to dest }
  5032. {       EDX     source          }
  5033.  
  5034.         TEST    EDX,EDX
  5035.         JE      @@sourceDone
  5036.  
  5037.         { bump up the ref count of the source }
  5038.  
  5039.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5040.         INC     ECX
  5041.         JLE     @@sourceDone
  5042.         MOV     [EDX-skew].StrRec.refCnt,ECX
  5043. @@sourceDone:
  5044.  
  5045.         { we need to release whatever the dest is pointing to   }
  5046.  
  5047.         XCHG    EDX,[EAX]                       { fetch str                    }
  5048.         TEST    EDX,EDX                         { if nil, nothing to do        }
  5049.         JE      @@done
  5050.         MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                 }
  5051.         DEC     ECX                             { if < 0: literal str          }
  5052.         JL      @@done
  5053.         MOV     [EDX-skew].StrRec.refCnt,ECX    { store refCount back          }
  5054.         JNE     @@done
  5055.         LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
  5056.         CALL    _FreeMem
  5057. @@done:
  5058. end;
  5059.  
  5060. procedure       _NewAnsiString{length: Longint};
  5061. asm
  5062.         { ->    EAX     length                  }
  5063.         { <-    EAX pointer to new string       }
  5064.  
  5065.         TEST    EAX,EAX
  5066.         JLE     @@null
  5067.         PUSH    EAX
  5068.         ADD     EAX,rOff+1
  5069.         CALL    _GetMem
  5070.         ADD     EAX,rOff
  5071.         POP     EDX
  5072.         MOV     [EAX-skew].StrRec.length,EDX
  5073.         MOV     [EAX-skew].StrRec.refCnt,1
  5074.         MOV     byte ptr [EAX+EDX],0
  5075.         RET
  5076.  
  5077. @@null:
  5078.         XOR     EAX,EAX
  5079. end;
  5080.  
  5081.  
  5082. procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  5083. asm
  5084.         { ->    EAX     pointer to dest }
  5085.         {       EDX source              }
  5086.         {       ECX length              }
  5087.  
  5088.         PUSH    EBX
  5089.         PUSH    ESI
  5090.         PUSH    EDI
  5091.  
  5092.         MOV     EBX,EAX
  5093.         MOV     ESI,EDX
  5094.         MOV     EDI,ECX
  5095.  
  5096.         { allocate new string }
  5097.  
  5098.         MOV     EAX,EDI
  5099.  
  5100.         CALL    _NewAnsiString
  5101.         MOV     ECX,EDI
  5102.         MOV     EDI,EAX
  5103.  
  5104.         TEST    ESI,ESI
  5105.         JE      @@noMove
  5106.  
  5107.         MOV     EDX,EAX
  5108.         MOV     EAX,ESI
  5109.         CALL    Move
  5110.  
  5111.         { assign the result to dest }
  5112.  
  5113. @@noMove:
  5114.         MOV     EAX,EBX
  5115.         CALL    _LStrClr
  5116.         MOV     [EBX],EDI
  5117.  
  5118.         POP     EDI
  5119.         POP     ESI
  5120.         POP     EBX
  5121. end;
  5122.  
  5123.  
  5124. procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  5125. var
  5126.   DestLen: Integer;
  5127.   Buffer: array[0..2047] of Char;
  5128. begin
  5129.   if Length <= 0 then
  5130.   begin
  5131.     _LStrClr(Dest);
  5132.     Exit;
  5133.   end;
  5134.   if Length < SizeOf(Buffer) div 2 then
  5135.   begin
  5136.     DestLen := WideCharToMultiByte(0, 0, Source, Length,
  5137.       Buffer, SizeOf(Buffer), nil, nil);
  5138.     if DestLen > 0 then
  5139.     begin
  5140.       _LStrFromPCharLen(Dest, Buffer, DestLen);
  5141.       Exit;
  5142.     end;
  5143.   end;
  5144.   DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);
  5145.   _LStrFromPCharLen(Dest, nil, DestLen);
  5146.   WideCharToMultiByte(0, 0, Source, Length, Pointer(Dest), DestLen, nil, nil);
  5147. end;
  5148.  
  5149.  
  5150. procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
  5151. asm
  5152.         PUSH    EDX
  5153.         MOV     EDX,ESP
  5154.         MOV     ECX,1
  5155.         CALL    _LStrFromPCharLen
  5156.         POP     EDX
  5157. end;
  5158.  
  5159.  
  5160. procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
  5161. asm
  5162.         PUSH    EDX
  5163.         MOV     EDX,ESP
  5164.         MOV     ECX,1
  5165.         CALL    _LStrFromPWCharLen
  5166.         POP     EDX
  5167. end;
  5168.  
  5169.  
  5170. procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
  5171. asm
  5172.         XOR     ECX,ECX
  5173.         TEST    EDX,EDX
  5174.         JE      @@5
  5175.         PUSH    EDX
  5176. @@0:    CMP     CL,[EDX+0]
  5177.         JE      @@4
  5178.         CMP     CL,[EDX+1]
  5179.         JE      @@3
  5180.         CMP     CL,[EDX+2]
  5181.         JE      @@2
  5182.         CMP     CL,[EDX+3]
  5183.         JE      @@1
  5184.         ADD     EDX,4
  5185.         JMP     @@0
  5186. @@1:    INC     EDX
  5187. @@2:    INC     EDX
  5188. @@3:    INC     EDX
  5189. @@4:    MOV     ECX,EDX
  5190.         POP     EDX
  5191.         SUB     ECX,EDX
  5192. @@5:    JMP     _LStrFromPCharLen
  5193. end;
  5194.  
  5195.  
  5196. procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
  5197. asm
  5198.         XOR     ECX,ECX
  5199.         TEST    EDX,EDX
  5200.         JE      @@5
  5201.         PUSH    EDX
  5202. @@0:    CMP     CX,[EDX+0]
  5203.         JE      @@4
  5204.         CMP     CX,[EDX+2]
  5205.         JE      @@3
  5206.         CMP     CX,[EDX+4]
  5207.         JE      @@2
  5208.         CMP     CX,[EDX+6]
  5209.         JE      @@1
  5210.         ADD     EDX,8
  5211.         JMP     @@0
  5212. @@1:    ADD     EDX,2
  5213. @@2:    ADD     EDX,2
  5214. @@3:    ADD     EDX,2
  5215. @@4:    MOV     ECX,EDX
  5216.         POP     EDX
  5217.         SUB     ECX,EDX
  5218.         SHR     ECX,1
  5219. @@5:    JMP     _LStrFromPWCharLen
  5220. end;
  5221.  
  5222.  
  5223. procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
  5224. asm
  5225.         XOR     ECX,ECX
  5226.         MOV     CL,[EDX]
  5227.         INC     EDX
  5228.         JMP     _LStrFromPCharLen
  5229. end;
  5230.  
  5231.  
  5232. procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
  5233. asm
  5234.         PUSH    EDI
  5235.         PUSH    EAX
  5236.         PUSH    ECX
  5237.         MOV     EDI,EDX
  5238.         XOR     EAX,EAX
  5239.         REPNE   SCASB
  5240.         JNE     @@1
  5241.         NOT     ECX
  5242. @@1:    POP     EAX
  5243.         ADD     ECX,EAX
  5244.         POP     EAX
  5245.         POP     EDI
  5246.         JMP     _LStrFromPCharLen
  5247. end;
  5248.  
  5249.  
  5250. procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
  5251. asm
  5252.         PUSH    EDI
  5253.         PUSH    EAX
  5254.         PUSH    ECX
  5255.         MOV     EDI,EDX
  5256.         XOR     EAX,EAX
  5257.         REPNE   SCASW
  5258.         JNE     @@1
  5259.         NOT     ECX
  5260. @@1:    POP     EAX
  5261.         ADD     ECX,EAX
  5262.         POP     EAX
  5263.         POP     EDI
  5264.         JMP     _LStrFromPWCharLen
  5265. end;
  5266.  
  5267.  
  5268. procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
  5269. asm
  5270.         XOR     ECX,ECX
  5271.         TEST    EDX,EDX
  5272.         JE      @@1
  5273.         MOV     ECX,[EDX-4]
  5274.         SHR     ECX,1
  5275. @@1:    JMP     _LStrFromPWCharLen
  5276. end;
  5277.  
  5278.  
  5279. procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
  5280. asm
  5281.         { ->    EAX pointer to result   }
  5282.         {       EDX AnsiString s        }
  5283.         {       ECX length of result    }
  5284.  
  5285.         PUSH    EBX
  5286.         TEST    EDX,EDX
  5287.         JE      @@empty
  5288.         MOV     EBX,[EDX-skew].StrRec.length
  5289.         TEST    EBX,EBX
  5290.         JE      @@empty
  5291.  
  5292.         CMP     ECX,EBX
  5293.         JL      @@truncate
  5294.         MOV     ECX,EBX
  5295. @@truncate:
  5296.         MOV     [EAX],CL
  5297.         INC     EAX
  5298.  
  5299.         XCHG    EAX,EDX
  5300.         CALL    Move
  5301.  
  5302.         JMP     @@exit
  5303.  
  5304. @@empty:
  5305.         MOV     byte ptr [EAX],0
  5306.  
  5307. @@exit:
  5308.         POP     EBX
  5309. end;
  5310.  
  5311.  
  5312. function        _LStrLen{str: AnsiString}: Longint;
  5313. asm
  5314.         { ->    EAX str }
  5315.  
  5316.         TEST    EAX,EAX
  5317.         JE      @@done
  5318.         MOV     EAX,[EAX-skew].StrRec.length;
  5319. @@done:
  5320. end;
  5321.  
  5322.  
  5323. procedure       _LStrCat{var dest: AnsiString; source: AnsiString};
  5324. asm
  5325.         { ->    EAX     pointer to dest }
  5326.         {       EDX source              }
  5327.  
  5328.         TEST    EDX,EDX
  5329.         JE      @@exit
  5330.  
  5331.         MOV     ECX,[EAX]
  5332.         TEST    ECX,ECX
  5333.         JE      _LStrAsg
  5334.  
  5335.         PUSH    EBX
  5336.         PUSH    ESI
  5337.         PUSH    EDI
  5338.         MOV     EBX,EAX
  5339.         MOV     ESI,EDX
  5340.         MOV     EDI,[ECX-skew].StrRec.length
  5341.  
  5342.         MOV     EDX,[ESI-skew].StrRec.length
  5343.         ADD     EDX,EDI
  5344.         CMP     ESI,ECX
  5345.         JE      @@appendSelf
  5346.  
  5347.         CALL    _LStrSetLength
  5348.         MOV     EAX,ESI
  5349.         MOV     ECX,[ESI-skew].StrRec.length
  5350.  
  5351. @@appendStr:
  5352.         MOV     EDX,[EBX]
  5353.         ADD     EDX,EDI
  5354.         CALL    Move
  5355.         POP     EDI
  5356.         POP     ESI
  5357.         POP     EBX
  5358.         RET
  5359.  
  5360. @@appendSelf:
  5361.         CALL    _LStrSetLength
  5362.         MOV     EAX,[EBX]
  5363.         MOV     ECX,EDI
  5364.         JMP     @@appendStr
  5365.  
  5366. @@exit:
  5367. end;
  5368.  
  5369.  
  5370. procedure       _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
  5371. asm
  5372.         {     ->EAX = Pointer to dest   }
  5373.         {       EDX = source1           }
  5374.         {       ECX = source2           }
  5375.  
  5376.         TEST    EDX,EDX
  5377.         JE      @@assignSource2
  5378.  
  5379.         TEST    ECX,ECX
  5380.         JE      _LStrAsg
  5381.  
  5382.         CMP     EDX,[EAX]
  5383.         JE      @@appendToDest
  5384.  
  5385.         CMP     ECX,[EAX]
  5386.         JE      @@theHardWay
  5387.  
  5388.         PUSH    EAX
  5389.         PUSH    ECX
  5390.         CALL    _LStrAsg
  5391.  
  5392.         POP     EDX
  5393.         POP     EAX
  5394.         JMP     _LStrCat
  5395.  
  5396. @@theHardWay:
  5397.  
  5398.         PUSH    EBX
  5399.         PUSH    ESI
  5400.         PUSH    EDI
  5401.  
  5402.         MOV     EBX,EDX
  5403.         MOV     ESI,ECX
  5404.         PUSH    EAX
  5405.  
  5406.         MOV     EAX,[EBX-skew].StrRec.length
  5407.         ADD     EAX,[ESI-skew].StrRec.length
  5408.         CALL    _NewAnsiString
  5409.  
  5410.         MOV     EDI,EAX
  5411.         MOV     EDX,EAX
  5412.         MOV     EAX,EBX
  5413.         MOV     ECX,[EBX-skew].StrRec.length
  5414.         CALL    Move
  5415.  
  5416.         MOV     EDX,EDI
  5417.         MOV     EAX,ESI
  5418.         MOV     ECX,[ESI-skew].StrRec.length
  5419.         ADD     EDX,[EBX-skew].StrRec.length
  5420.         CALL    Move
  5421.  
  5422.         POP     EAX
  5423.         MOV     EDX,EDI
  5424.         TEST    EDI,EDI
  5425.         JE      @@skip
  5426.         DEC     [EDI-skew].StrRec.refCnt
  5427. @@skip:
  5428.         CALL    _LStrAsg
  5429.  
  5430.         POP     EDI
  5431.         POP     ESI
  5432.         POP     EBX
  5433.  
  5434.         JMP     @@exit
  5435.  
  5436. @@assignSource2:
  5437.         MOV     EDX,ECX
  5438.         JMP     _LStrAsg
  5439.  
  5440. @@appendToDest:
  5441.         MOV     EDX,ECX
  5442.         JMP     _LStrCat
  5443.  
  5444. @@exit:
  5445. end;
  5446.  
  5447.  
  5448. procedure       _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
  5449. asm
  5450.         {     ->EAX = Pointer to dest   }
  5451.         {       EDX = number of args (>= 3)     }
  5452.         {       [ESP+4], [ESP+8], ... crgCnt AnsiString arguments }
  5453.  
  5454.         PUSH    EBX
  5455.         PUSH    ESI
  5456.         PUSH    EDX
  5457.         PUSH    EAX
  5458.         MOV     EBX,EDX
  5459.  
  5460.         XOR     EAX,EAX
  5461. @@loop1:
  5462.         MOV     ECX,[ESP+EDX*4+4*4]
  5463.         TEST    ECX,ECX
  5464.         JE      @@1
  5465.         ADD     EAX,[ECX-skew].StrRec.length
  5466. @@1:
  5467.         DEC     EDX
  5468.         JNE     @@loop1
  5469.  
  5470.         CALL    _NewAnsiString
  5471.         PUSH    EAX
  5472.         MOV     ESI,EAX
  5473.  
  5474. @@loop2:
  5475.         MOV     EAX,[ESP+EBX*4+5*4]
  5476.         MOV     EDX,ESI
  5477.         TEST    EAX,EAX
  5478.         JE      @@2
  5479.         MOV     ECX,[EAX-skew].StrRec.length
  5480.         ADD     ESI,ECX
  5481.         CALL    Move
  5482. @@2:
  5483.         DEC     EBX
  5484.         JNE     @@loop2
  5485.  
  5486.         POP     EDX
  5487.         POP     EAX
  5488.         TEST    EDX,EDX
  5489.         JE      @@skip
  5490.         DEC     [EDX-skew].StrRec.refCnt
  5491. @@skip:
  5492.         CALL    _LStrAsg
  5493.  
  5494.         POP     EDX
  5495.         POP     ESI
  5496.         POP     EBX
  5497.         POP     EAX
  5498.         LEA     ESP,[ESP+EDX*4]
  5499.         JMP     EAX
  5500. end;
  5501.  
  5502.  
  5503. procedure       _LStrCmp{left: AnsiString; right: AnsiString};
  5504. asm
  5505. {     ->EAX = Pointer to left string    }
  5506. {       EDX = Pointer to right string   }
  5507.  
  5508.         PUSH    EBX
  5509.         PUSH    ESI
  5510.         PUSH    EDI
  5511.  
  5512.         MOV     ESI,EAX
  5513.         MOV     EDI,EDX
  5514.  
  5515.         CMP     EAX,EDX
  5516.         JE      @@exit
  5517.  
  5518.         TEST    ESI,ESI
  5519.         JE      @@str1null
  5520.  
  5521.         TEST    EDI,EDI
  5522.         JE      @@str2null
  5523.  
  5524.         MOV     EAX,[ESI-skew].StrRec.length
  5525.         MOV     EDX,[EDI-skew].StrRec.length
  5526.  
  5527.         SUB     EAX,EDX { eax = len1 - len2 }
  5528.         JA      @@skip1
  5529.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  5530.  
  5531. @@skip1:
  5532.         PUSH    EDX
  5533.         SHR     EDX,2
  5534.         JE      @@cmpRest
  5535. @@longLoop:
  5536.         MOV     ECX,[ESI]
  5537.         MOV     EBX,[EDI]
  5538.         CMP     ECX,EBX
  5539.         JNE     @@misMatch
  5540.         DEC     EDX
  5541.         JE      @@cmpRestP4
  5542.         MOV     ECX,[ESI+4]
  5543.         MOV     EBX,[EDI+4]
  5544.         CMP     ECX,EBX
  5545.         JNE     @@misMatch
  5546.         ADD     ESI,8
  5547.         ADD     EDI,8
  5548.         DEC     EDX
  5549.         JNE     @@longLoop
  5550.         JMP     @@cmpRest
  5551. @@cmpRestP4:
  5552.         ADD     ESI,4
  5553.         ADD     EDI,4
  5554. @@cmpRest:
  5555.         POP     EDX
  5556.         AND     EDX,3
  5557.         JE      @@equal
  5558.  
  5559.         MOV     ECX,[ESI]
  5560.         MOV     EBX,[EDI]
  5561.         CMP     CL,BL
  5562.         JNE     @@exit
  5563.         DEC     EDX
  5564.         JE      @@equal
  5565.         CMP     CH,BH
  5566.         JNE     @@exit
  5567.         DEC     EDX
  5568.         JE      @@equal
  5569.         AND     EBX,$00FF0000
  5570.         AND     ECX,$00FF0000
  5571.         CMP     ECX,EBX
  5572.         JNE     @@exit
  5573.  
  5574. @@equal:
  5575.         ADD     EAX,EAX
  5576.         JMP     @@exit
  5577.  
  5578. @@str1null:
  5579.         MOV     EDX,[EDI-skew].StrRec.length
  5580.         SUB     EAX,EDX
  5581.         JMP     @@exit
  5582.  
  5583. @@str2null:
  5584.         MOV     EAX,[ESI-skew].StrRec.length
  5585.         SUB     EAX,EDX
  5586.         JMP     @@exit
  5587.  
  5588. @@misMatch:
  5589.         POP     EDX
  5590.         CMP     CL,BL
  5591.         JNE     @@exit
  5592.         CMP     CH,BH
  5593.         JNE     @@exit
  5594.         SHR     ECX,16
  5595.         SHR     EBX,16
  5596.         CMP     CL,BL
  5597.         JNE     @@exit
  5598.         CMP     CH,BH
  5599.  
  5600. @@exit:
  5601.         POP     EDI
  5602.         POP     ESI
  5603.         POP     EBX
  5604.  
  5605. end;
  5606.  
  5607.  
  5608. procedure       _LStrAddRef{str: AnsiString};
  5609. asm
  5610.         { ->    EAX     str     }
  5611.         TEST    EAX,EAX
  5612.         JE      @@exit
  5613.         MOV     EDX,[EAX-skew].StrRec.refCnt
  5614.         INC     EDX
  5615.         JLE     @@exit
  5616.         MOV     [EAX-skew].StrRec.refCnt,EDX
  5617. @@exit:
  5618. end;
  5619.  
  5620.  
  5621. procedure       _LStrToPChar{str: AnsiString): PChar};
  5622. asm
  5623.         { ->    EAX pointer to str              }
  5624.         { <-    EAX pointer to PChar    }
  5625.  
  5626.         TEST    EAX,EAX
  5627.         JE      @@handle0
  5628.         RET
  5629. @@zeroByte:
  5630.         DB      0
  5631. @@handle0:
  5632.         MOV     EAX,offset @@zeroByte
  5633. end;
  5634.  
  5635.  
  5636. procedure       UniqueString(var str: string);
  5637. asm
  5638.         { ->    EAX pointer to str              }
  5639.         { <-    EAX pointer to unique copy      }
  5640.         MOV     EDX,[EAX]
  5641.         TEST    EDX,EDX
  5642.         JE      @@exit
  5643.         MOV     ECX,[EDX-skew].StrRec.refCnt
  5644.         DEC     ECX
  5645.         JE      @@exit
  5646.  
  5647.         PUSH    EBX
  5648.         MOV     EBX,EAX
  5649.         MOV     EAX,[EDX-skew].StrRec.length
  5650.         CALL    _NewAnsiString
  5651.         MOV     EDX,EAX
  5652.         MOV     EAX,[EBX]
  5653.         MOV     [EBX],EDX
  5654.         MOV     ECX,[EAX-skew].StrRec.refCnt
  5655.         DEC     ECX
  5656.         JL      @@skip
  5657.         MOV     [EAX-skew].StrRec.refCnt,ECX
  5658. @@skip:
  5659.         MOV     ECX,[EAX-skew].StrRec.length
  5660.         CALL    Move
  5661.         MOV     EDX,[EBX]
  5662.         POP     EBX
  5663. @@exit:
  5664.         MOV     EAX,EDX
  5665. end;
  5666.  
  5667.  
  5668. procedure       _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString};
  5669. asm
  5670.         {     ->EAX     Source string                   }
  5671.         {       EDX     index                           }
  5672.         {       ECX     count                           }
  5673.         {       [ESP+4] Pointer to result string        }
  5674.  
  5675.         PUSH    EBX
  5676.  
  5677.         TEST    EAX,EAX
  5678.         JE      @@srcEmpty
  5679.  
  5680.         MOV     EBX,[EAX-skew].StrRec.length
  5681.         TEST    EBX,EBX
  5682.         JE      @@srcEmpty
  5683.  
  5684. {       make index 0-based and limit to 0 <= index < Length(src) }
  5685.  
  5686.         DEC     EDX
  5687.         JL      @@smallInx
  5688.         CMP     EDX,EBX
  5689.         JGE     @@bigInx
  5690.  
  5691. @@cont1:
  5692.  
  5693. {       limit count to satisfy 0 <= count <= Length(src) - index        }
  5694.  
  5695.         SUB     EBX,EDX { calculate Length(src) - index }
  5696.         TEST    ECX,ECX
  5697.         JL      @@smallCount
  5698.         CMP     ECX,EBX
  5699.         JG      @@bigCount
  5700.  
  5701. @@cont2:
  5702.  
  5703.         ADD     EDX,EAX
  5704.         MOV     EAX,[ESP+4+4]
  5705.         CALL    _LStrFromPCharLen
  5706.         JMP     @@exit
  5707.  
  5708. @@smallInx:
  5709.         XOR     EDX,EDX
  5710.         JMP     @@cont1
  5711. @@bigCount:
  5712.         MOV     ECX,EBX
  5713.         JMP     @@cont2
  5714. @@bigInx:
  5715. @@smallCount:
  5716. @@srcEmpty:
  5717.         MOV     EAX,[ESP+4+4]
  5718.         CALL    _LStrClr
  5719. @@exit:
  5720.         POP     EBX
  5721.         RET     4
  5722. end;
  5723.  
  5724.  
  5725. procedure       _LStrDelete{ var s : AnsiString; index, count : Integer };
  5726. asm
  5727.         {     ->EAX     Pointer to s    }
  5728.         {       EDX     index           }
  5729.         {       ECX     count           }
  5730.  
  5731.         PUSH    EBX
  5732.         PUSH    ESI
  5733.         PUSH    EDI
  5734.  
  5735.         MOV     EBX,EAX
  5736.         MOV     ESI,EDX
  5737.         MOV     EDI,ECX
  5738.  
  5739.         CALL    UniqueString
  5740.  
  5741.         MOV     EDX,[EBX]
  5742.         TEST    EDX,EDX         { source already empty: nothing to do   }
  5743.         JE      @@exit
  5744.  
  5745.         MOV     ECX,[EDX-skew].StrRec.length
  5746.  
  5747. {       make index 0-based, if not in [0 .. Length(s)-1] do nothing     }
  5748.  
  5749.         DEC     ESI
  5750.         JL      @@exit
  5751.         CMP     ESI,ECX
  5752.         JGE     @@exit
  5753.  
  5754. {       limit count to [0 .. Length(s) - index] }
  5755.  
  5756.         TEST    EDI,EDI
  5757.         JLE     @@exit
  5758.         SUB     ECX,ESI         { ECX = Length(s) - index       }
  5759.         CMP     EDI,ECX
  5760.         JLE     @@1
  5761.         MOV     EDI,ECX
  5762. @@1:
  5763.  
  5764. {       move length - index - count characters from s+index+count to s+index }
  5765.  
  5766.         SUB     ECX,EDI         { ECX = Length(s) - index - count       }
  5767.         ADD     EDX,ESI         { EDX = s+index                 }
  5768.         LEA     EAX,[EDX+EDI]   { EAX = s+index+count           }
  5769.         CALL    Move
  5770.  
  5771. {       set length(s) to length(s) - count      }
  5772.  
  5773.         MOV     EDX,[EBX]
  5774.         MOV     EAX,EBX
  5775.         MOV     EDX,[EDX-skew].StrRec.length
  5776.         SUB     EDX,EDI
  5777.         CALL    _LStrSetLength
  5778.  
  5779. @@exit:
  5780.         POP     EDI
  5781.         POP     ESI
  5782.         POP     EBX
  5783. end;
  5784.  
  5785.  
  5786. procedure       _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
  5787. asm
  5788.         { ->    EAX source string                       }
  5789.         {       EDX     pointer to destination string   }
  5790.         {       ECX index                               }
  5791.  
  5792.         TEST    EAX,EAX
  5793.         JE      @@nothingToDo
  5794.  
  5795.         PUSH    EBX
  5796.         PUSH    ESI
  5797.         PUSH    EDI
  5798.         PUSH    EBP
  5799.  
  5800.         MOV     EBX,EAX
  5801.         MOV     ESI,EDX
  5802.         MOV     EDI,ECX
  5803.  
  5804. {       make index 0-based and limit to 0 <= index <= Length(s) }
  5805.  
  5806.         MOV     EDX,[EDX]
  5807.         PUSH    EDX
  5808.         TEST    EDX,EDX
  5809.         JE      @@sIsNull
  5810.         MOV     EDX,[EDX-skew].StrRec.length
  5811. @@sIsNull:
  5812.         DEC     EDI
  5813.         JGE     @@indexNotLow
  5814.         XOR     EDI,EDI
  5815. @@indexNotLow:
  5816.         CMP     EDI,EDX
  5817.         JLE     @@indexNotHigh
  5818.         MOV     EDI,EDX
  5819. @@indexNotHigh:
  5820.  
  5821.         MOV     EBP,[EBX-skew].StrRec.length
  5822.  
  5823. {       set length of result to length(source) + length(s)      }
  5824.  
  5825.         MOV     EAX,ESI
  5826.         ADD     EDX,EBP
  5827.         CALL    _LStrSetLength
  5828.         POP     EAX
  5829.  
  5830.         CMP     EAX,EBX
  5831.         JNE     @@notInsertSelf
  5832.         MOV     EBX,[ESI]
  5833.  
  5834. @@notInsertSelf:
  5835.  
  5836. {       move length(s) - length(source) - index chars from s+index to s+index+length(source) }
  5837.  
  5838.         MOV     EAX,[ESI]                       { EAX = s       }
  5839.         LEA     EDX,[EDI+EBP]                   { EDX = index + length(source)  }
  5840.         MOV     ECX,[EAX-skew].StrRec.length
  5841.         SUB     ECX,EDX                         { ECX = length(s) - length(source) - index }
  5842.         ADD     EDX,EAX                         { EDX = s + index + length(source)      }
  5843.         ADD     EAX,EDI                         { EAX = s + index       }
  5844.         CALL    Move
  5845.  
  5846. {       copy length(source) chars from source to s+index        }
  5847.  
  5848.         MOV     EAX,EBX
  5849.         MOV     EDX,[ESI]
  5850.         MOV     ECX,EBP
  5851.         ADD     EDX,EDI
  5852.         CALL    Move
  5853.  
  5854. @@exit:
  5855.         POP     EBP
  5856.         POP     EDI
  5857.         POP     ESI
  5858.         POP     EBX
  5859. @@nothingToDo:
  5860. end;
  5861.  
  5862.  
  5863. procedure       _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
  5864. asm
  5865. {     ->EAX     Pointer to substr               }
  5866. {       EDX     Pointer to string               }
  5867. {     <-EAX     Position of substr in s or 0    }
  5868.  
  5869.         TEST    EAX,EAX
  5870.         JE      @@noWork
  5871.  
  5872.         TEST    EDX,EDX
  5873.         JE      @@stringEmpty
  5874.  
  5875.         PUSH    EBX
  5876.         PUSH    ESI
  5877.         PUSH    EDI
  5878.  
  5879.         MOV     ESI,EAX                         { Point ESI to substr           }
  5880.         MOV     EDI,EDX                         { Point EDI to s                }
  5881.  
  5882.         MOV     ECX,[EDI-skew].StrRec.length    { ECX = Length(s)               }
  5883.  
  5884.         PUSH    EDI                             { remember s position to calculate index        }
  5885.  
  5886.         MOV     EDX,[ESI-skew].StrRec.length    { EDX = Length(substr)          }
  5887.  
  5888.         DEC     EDX                             { EDX = Length(substr) - 1              }
  5889.         JS      @@fail                          { < 0 ? return 0                        }
  5890.         MOV     AL,[ESI]                        { AL = first char of substr             }
  5891.         INC     ESI                             { Point ESI to 2'nd char of substr      }
  5892.  
  5893.         SUB     ECX,EDX                         { #positions in s to look at    }
  5894.                                                 { = Length(s) - Length(substr) + 1      }
  5895.         JLE     @@fail
  5896. @@loop:
  5897.         REPNE   SCASB
  5898.         JNE     @@fail
  5899.         MOV     EBX,ECX                         { save outer loop counter               }
  5900.         PUSH    ESI                             { save outer loop substr pointer        }
  5901.         PUSH    EDI                             { save outer loop s pointer             }
  5902.  
  5903.         MOV     ECX,EDX
  5904.         REPE    CMPSB
  5905.         POP     EDI                             { restore outer loop s pointer  }
  5906.         POP     ESI                             { restore outer loop substr pointer     }
  5907.         JE      @@found
  5908.         MOV     ECX,EBX                         { restore outer loop counter    }
  5909.         JMP     @@loop
  5910.  
  5911. @@fail:
  5912.         POP     EDX                             { get rid of saved s pointer    }
  5913.         XOR     EAX,EAX
  5914.         JMP     @@exit
  5915.  
  5916. @@stringEmpty:
  5917.         XOR     EAX,EAX
  5918.         JMP     @@noWork
  5919.  
  5920. @@found:
  5921.         POP     EDX                             { restore pointer to first char of s    }
  5922.         MOV     EAX,EDI                         { EDI points of char after match        }
  5923.         SUB     EAX,EDX                         { the difference is the correct index   }
  5924. @@exit:
  5925.         POP     EDI
  5926.         POP     ESI
  5927.         POP     EBX
  5928. @@noWork:
  5929. end;
  5930.  
  5931.  
  5932. procedure       _LStrSetLength{ var str: AnsiString; newLength: Integer};
  5933. asm
  5934.         { ->    EAX     Pointer to str  }
  5935.         {       EDX new length  }
  5936.  
  5937.         PUSH    EBX
  5938.         PUSH    ESI
  5939.         PUSH    EDI
  5940.         MOV     EBX,EAX
  5941.         MOV     ESI,EDX
  5942.         XOR     EDI,EDI
  5943.  
  5944.         TEST    EDX,EDX
  5945.         JE      @@setString
  5946.  
  5947.         MOV     EAX,[EBX]
  5948.         TEST    EAX,EAX
  5949.         JE      @@copyString
  5950.  
  5951.         CMP     [EAX-skew].StrRec.refCnt,1
  5952.         JNE     @@copyString
  5953.  
  5954.         SUB     EAX,rOff
  5955.         ADD     EDX,rOff+1
  5956.         PUSH    EAX
  5957.         MOV     EAX,ESP
  5958.         CALL    _ReallocMem
  5959.         POP     EAX
  5960.         ADD     EAX,rOff
  5961.         MOV     [EBX],EAX
  5962.         MOV     [EAX-skew].StrRec.length,ESI
  5963.         MOV     BYTE PTR [EAX+ESI],0
  5964.         JMP     @@exit
  5965.  
  5966. @@copyString:
  5967.         MOV     EAX,EDX
  5968.         CALL    _NewAnsiString
  5969.         MOV     EDI,EAX
  5970.  
  5971.         MOV     EAX,[EBX]
  5972.         TEST    EAX,EAX
  5973.         JE      @@setString
  5974.  
  5975.         MOV     EDX,EDI
  5976.         MOV     ECX,[EAX-skew].StrRec.length
  5977.         CMP     ECX,ESI
  5978.         JL      @@moveString
  5979.         MOV     ECX,ESI
  5980.  
  5981. @@moveString:
  5982.         CALL    Move
  5983.  
  5984. @@setString:
  5985.         MOV     EAX,EBX
  5986.         CALL    _LStrClr
  5987.         MOV     [EBX],EDI
  5988.  
  5989. @@exit:
  5990.         POP     EDI
  5991.         POP     ESI
  5992.         POP     EBX
  5993. end;
  5994.  
  5995.  
  5996. procedure       _LStrOfChar{ c: Char; count: Integer): AnsiString };
  5997. asm
  5998.         { ->    AL      c               }
  5999.         {       EDX     count           }
  6000.         {       ECX     result  }
  6001.  
  6002.         PUSH    EBX
  6003.         PUSH    ESI
  6004.         PUSH    EDI
  6005.  
  6006.         MOV     EBX,EAX
  6007.         MOV     ESI,EDX
  6008.         MOV     EDI,ECX
  6009.  
  6010.         MOV     EAX,ECX
  6011.         CALL    _LStrClr
  6012.  
  6013.         TEST    ESI,ESI
  6014.     JLE @@exit
  6015.  
  6016.         MOV     EAX,ESI
  6017.         CALL    _NewAnsiString
  6018.  
  6019.         MOV     [EDI],EAX
  6020.  
  6021.         MOV     EDX,ESI
  6022.         MOV     CL,BL
  6023.  
  6024.         CALL    _FillChar
  6025.  
  6026. @@exit:
  6027.         POP     EDI
  6028.         POP     ESI
  6029.         POP     EBX
  6030.  
  6031. end;
  6032.  
  6033.  
  6034. procedure _Write0LString{ VAR t: Text; s: AnsiString };
  6035. asm
  6036.         { ->    EAX     Pointer to text record  }
  6037.         {       EDX     Pointer to AnsiString   }
  6038.  
  6039.         XOR     ECX,ECX
  6040.         JMP     _WriteLString
  6041. end;
  6042.  
  6043.  
  6044. procedure _WriteLString{ VAR t: Text; s: AnsiString; width: Longint };
  6045. asm
  6046.         { ->    EAX     Pointer to text record  }
  6047.         {       EDX     Pointer to AnsiString   }
  6048.         {       ECX     Field width             }
  6049.  
  6050.         PUSH    EBX
  6051.  
  6052.         MOV     EBX,EDX
  6053.  
  6054.         MOV     EDX,ECX
  6055.         XOR     ECX,ECX
  6056.         TEST    EBX,EBX
  6057.         JE      @@skip
  6058.         MOV     ECX,[EBX-skew].StrRec.length
  6059.         SUB     EDX,ECX
  6060. @@skip:
  6061.         PUSH    ECX
  6062.         CALL    _WriteSpaces
  6063.         POP     ECX
  6064.  
  6065.         MOV     EDX,EBX
  6066.         POP     EBX
  6067.         JMP     _WriteBytes
  6068. end;
  6069.  
  6070.  
  6071. procedure       _ReadLString{var t: Text; var str: AnsiString};
  6072. asm
  6073.         { ->    EAX     pointer to Text         }
  6074.         {       EDX     pointer to AnsiString   }
  6075.  
  6076.         PUSH    EBX
  6077.         PUSH    ESI
  6078.         MOV     EBX,EAX
  6079.         MOV     ESI,EDX
  6080.  
  6081.         MOV     EAX,EDX
  6082.         CALL    _LStrClr
  6083.  
  6084.         SUB     ESP,256
  6085.  
  6086.         MOV     EAX,EBX
  6087.         MOV     EDX,ESP
  6088.         MOV     ECX,255
  6089.         CALL    _ReadString
  6090.  
  6091.         MOV     EAX,ESI
  6092.         MOV     EDX,ESP
  6093.         CALL    _LStrFromString
  6094.  
  6095.         CMP     byte ptr [ESP],255
  6096.         JNE     @@exit
  6097. @@loop:
  6098.  
  6099.         MOV     EAX,EBX
  6100.         MOV     EDX,ESP
  6101.         MOV     ECX,255
  6102.         CALL    _ReadString
  6103.  
  6104.         MOV     EDX,ESP
  6105.         PUSH    0
  6106.         MOV     EAX,ESP
  6107.         CALL    _LStrFromString
  6108.  
  6109.         MOV     EAX,ESI
  6110.         MOV     EDX,[ESP]
  6111.         CALL    _LStrCat
  6112.  
  6113.         MOV     EAX,ESP
  6114.         CALL    _LStrClr
  6115.         POP     EAX
  6116.  
  6117.         CMP     byte ptr [ESP],255
  6118.         JE      @@loop
  6119.  
  6120. @@exit:
  6121.         ADD     ESP,256
  6122.         POP     ESI
  6123.         POP     EBX
  6124. end;
  6125.  
  6126.  
  6127. procedure WStrError;
  6128. asm
  6129.         MOV     AL,reOutOfMemory
  6130.         JMP     Error
  6131. end;
  6132.  
  6133.  
  6134. procedure WStrSet(var S: WideString; P: PWideChar);
  6135. asm
  6136.         MOV     ECX,[EAX]
  6137.         MOV     [EAX],EDX
  6138.         TEST    ECX,ECX
  6139.         JE      @@1
  6140.         PUSH    ECX
  6141.         CALL    SysFreeString
  6142. @@1:
  6143. end;
  6144.  
  6145.  
  6146. procedure _WStrClr(var S: WideString);
  6147. asm
  6148.         MOV     EDX,[EAX]
  6149.         TEST    EDX,EDX
  6150.         JE      @@1
  6151.         MOV     DWORD PTR [EAX],0
  6152.         PUSH    EAX
  6153.         PUSH    EDX
  6154.         CALL    SysFreeString
  6155.         POP     EAX
  6156. @@1:
  6157. end;
  6158.  
  6159.  
  6160. procedure _WStrArrayClr(var StrArray; Count: Integer);
  6161. asm
  6162.         PUSH    EBX
  6163.         PUSH    ESI
  6164.         MOV     EBX,EAX
  6165.         MOV     ESI,EDX
  6166. @@1:    MOV     EAX,[EBX]
  6167.         TEST    EAX,EAX
  6168.         JE      @@2
  6169.         MOV     DWORD PTR [EBX],0
  6170.         PUSH    EAX
  6171.         CALL    SysFreeString
  6172. @@2:    ADD     EBX,4
  6173.         DEC     ESI
  6174.         JNE     @@1
  6175.         POP     ESI
  6176.         POP     EBX
  6177. end;
  6178.  
  6179.  
  6180. procedure _WStrAsg(var Dest: WideString; const Source: WideString);
  6181. asm
  6182.         TEST    EDX,EDX
  6183.         JE      _WStrClr
  6184.         MOV     ECX,[EDX-4]
  6185.         SHR     ECX,1
  6186.         JE      _WStrClr
  6187.         PUSH    ECX
  6188.         PUSH    EDX
  6189.         PUSH    EAX
  6190.         CALL    SysReAllocStringLen
  6191.         TEST    EAX,EAX
  6192.         JE      WStrError
  6193. end;
  6194.  
  6195.  
  6196. procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  6197. var
  6198.   DestLen: Integer;
  6199.   Buffer: array[0..1023] of WideChar;
  6200. begin
  6201.   if Length <= 0 then
  6202.   begin
  6203.     _WStrClr(Dest);
  6204.     Exit;
  6205.   end;
  6206.   if Length < SizeOf(Buffer) div 2 then
  6207.   begin
  6208.     DestLen := MultiByteToWideChar(0, 0, Source, Length,
  6209.       Buffer, SizeOf(Buffer) div 2);
  6210.     if DestLen > 0 then
  6211.     begin
  6212.       _WStrFromPWCharLen(Dest, Buffer, DestLen);
  6213.       Exit;
  6214.     end;
  6215.   end;
  6216.   DestLen := MultiByteToWideChar(0, 0, Source, Length, nil, 0);
  6217.   _WStrFromPWCharLen(Dest, nil, DestLen);
  6218.   MultiByteToWideChar(0, 0, Source, Length, Pointer(Dest), DestLen);
  6219. end;
  6220.  
  6221.  
  6222. procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
  6223. asm
  6224.         TEST    ECX,ECX
  6225.         JE      _WStrClr
  6226.         PUSH    ECX
  6227.         PUSH    EDX
  6228.         PUSH    EAX
  6229.         CALL    SysReAllocStringLen
  6230.         TEST    EAX,EAX
  6231.         JE      WStrError
  6232. end;
  6233.  
  6234.  
  6235. procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
  6236. asm
  6237.         PUSH    EDX
  6238.         MOV     EDX,ESP
  6239.         MOV     ECX,1
  6240.         CALL    _WStrFromPCharLen
  6241.         POP     EDX
  6242. end;
  6243.  
  6244.  
  6245. procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
  6246. asm
  6247.         PUSH    EDX
  6248.         MOV     EDX,ESP
  6249.         MOV     ECX,1
  6250.         CALL    _WStrFromPWCharLen
  6251.         POP     EDX
  6252. end;
  6253.  
  6254.  
  6255. procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
  6256. asm
  6257.         XOR     ECX,ECX
  6258.         TEST    EDX,EDX
  6259.         JE      @@5
  6260.         PUSH    EDX
  6261. @@0:    CMP     CL,[EDX+0]
  6262.         JE      @@4
  6263.         CMP     CL,[EDX+1]
  6264.         JE      @@3
  6265.         CMP     CL,[EDX+2]
  6266.         JE      @@2
  6267.         CMP     CL,[EDX+3]
  6268.         JE      @@1
  6269.         ADD     EDX,4
  6270.         JMP     @@0
  6271. @@1:    INC     EDX
  6272. @@2:    INC     EDX
  6273. @@3:    INC     EDX
  6274. @@4:    MOV     ECX,EDX
  6275.         POP     EDX
  6276.         SUB     ECX,EDX
  6277. @@5:    JMP     _WStrFromPCharLen
  6278. end;
  6279.  
  6280.  
  6281. procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
  6282. asm
  6283.         XOR     ECX,ECX
  6284.         TEST    EDX,EDX
  6285.         JE      @@5
  6286.         PUSH    EDX
  6287. @@0:    CMP     CX,[EDX+0]
  6288.         JE      @@4
  6289.         CMP     CX,[EDX+2]
  6290.         JE      @@3
  6291.         CMP     CX,[EDX+4]
  6292.         JE      @@2
  6293.         CMP     CX,[EDX+6]
  6294.         JE      @@1
  6295.         ADD     EDX,8
  6296.         JMP     @@0
  6297. @@1:    ADD     EDX,2
  6298. @@2:    ADD     EDX,2
  6299. @@3:    ADD     EDX,2
  6300. @@4:    MOV     ECX,EDX
  6301.         POP     EDX
  6302.         SUB     ECX,EDX
  6303.         SHR     ECX,1
  6304. @@5:    JMP     _WStrFromPWCharLen
  6305. end;
  6306.  
  6307.  
  6308. procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
  6309. asm
  6310.         XOR     ECX,ECX
  6311.         MOV     CL,[EDX]
  6312.         INC     EDX
  6313.         JMP     _WStrFromPCharLen
  6314. end;
  6315.  
  6316.  
  6317. procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
  6318. asm
  6319.         PUSH    EDI
  6320.         PUSH    EAX
  6321.         PUSH    ECX
  6322.         MOV     EDI,EDX
  6323.         XOR     EAX,EAX
  6324.         REPNE   SCASB
  6325.         JNE     @@1
  6326.         NOT     ECX
  6327. @@1:    POP     EAX
  6328.         ADD     ECX,EAX
  6329.         POP     EAX
  6330.         POP     EDI
  6331.         JMP     _WStrFromPCharLen
  6332. end;
  6333.  
  6334.  
  6335. procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
  6336. asm
  6337.         PUSH    EDI
  6338.         PUSH    EAX
  6339.         PUSH    ECX
  6340.         MOV     EDI,EDX
  6341.         XOR     EAX,EAX
  6342.         REPNE   SCASW
  6343.         JNE     @@1
  6344.         NOT     ECX
  6345. @@1:    POP     EAX
  6346.         ADD     ECX,EAX
  6347.         POP     EAX
  6348.         POP     EDI
  6349.         JMP     _WStrFromPWCharLen
  6350. end;
  6351.  
  6352.  
  6353. procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
  6354. asm
  6355.         XOR     ECX,ECX
  6356.         TEST    EDX,EDX
  6357.         JE      @@1
  6358.         MOV     ECX,[EDX-4]
  6359. @@1:    JMP     _WStrFromPCharLen
  6360. end;
  6361.  
  6362.  
  6363. procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
  6364. var
  6365.   SourceLen, DestLen: Integer;
  6366.   Buffer: array[0..511] of Char;
  6367. begin
  6368.   SourceLen := Length(Source);
  6369.   if SourceLen = 0 then DestLen := 0 else
  6370.   begin
  6371.     DestLen := WideCharToMultiByte(0, 0, Pointer(Source), SourceLen,
  6372.       Buffer, SizeOf(Buffer), nil, nil);
  6373.     if DestLen > MaxLen then DestLen := MaxLen;
  6374.   end;
  6375.   Dest^[0] := Chr(DestLen);
  6376.   if DestLen > 0 then Move(Buffer, Dest^[1], DestLen);
  6377. end;
  6378.  
  6379.  
  6380. function _WStrToPWChar(const S: WideString): PWideChar;
  6381. asm
  6382.         TEST    EAX,EAX
  6383.         JE      @@1
  6384.         RET
  6385.         NOP
  6386. @@0:    DW      0
  6387. @@1:    MOV     EAX,OFFSET @@0
  6388. end;
  6389.  
  6390.  
  6391. function _WStrLen(const S: WideString): Integer;
  6392. asm
  6393.         TEST    EAX,EAX
  6394.         JE      @@1
  6395.         MOV     EAX,[EAX-4]
  6396.         SHR     EAX,1
  6397. @@1:
  6398. end;
  6399.  
  6400.  
  6401. procedure _WStrCat(var Dest: WideString; const Source: WideString);
  6402. var
  6403.   DestLen, SourceLen: Integer;
  6404.   NewStr: PWideChar;
  6405. begin
  6406.   SourceLen := Length(Source);
  6407.   if SourceLen <> 0 then
  6408.   begin
  6409.     DestLen := Length(Dest);
  6410.     NewStr := _NewWideString(DestLen + SourceLen);
  6411.     if DestLen > 0 then
  6412.       Move(Pointer(Dest)^, NewStr^, DestLen * 2);
  6413.     Move(Pointer(Source)^, NewStr[DestLen], SourceLen * 2);
  6414.     WStrSet(Dest, NewStr);
  6415.   end;
  6416. end;
  6417.  
  6418.  
  6419. procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
  6420. var
  6421.   Source1Len, Source2Len: Integer;
  6422.   NewStr: PWideChar;
  6423. begin
  6424.   Source1Len := Length(Source1);
  6425.   Source2Len := Length(Source2);
  6426.   if (Source1Len <> 0) or (Source2Len <> 0) then
  6427.   begin
  6428.     NewStr := _NewWideString(Source1Len + Source2Len);
  6429.     Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * 2);
  6430.     Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * 2);
  6431.     WStrSet(Dest, NewStr);
  6432.   end;
  6433. end;
  6434.  
  6435.  
  6436. procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...};
  6437. asm
  6438.         {     ->EAX = Pointer to dest }
  6439.         {       EDX = number of args (>= 3) }
  6440.         {       [ESP+4], [ESP+8], ... crgCnt WideString arguments }
  6441.  
  6442.         PUSH    EBX
  6443.         PUSH    ESI
  6444.         PUSH    EDX
  6445.         PUSH    EAX
  6446.         MOV     EBX,EDX
  6447.  
  6448.         XOR     EAX,EAX
  6449. @@loop1:
  6450.         MOV     ECX,[ESP+EDX*4+4*4]
  6451.         TEST    ECX,ECX
  6452.         JE      @@1
  6453.         ADD     EAX,[ECX-4]
  6454. @@1:
  6455.         DEC     EDX
  6456.         JNE     @@loop1
  6457.  
  6458.         SHR     EAX,1
  6459.         CALL    _NewWideString
  6460.         PUSH    EAX
  6461.         MOV     ESI,EAX
  6462.  
  6463. @@loop2:
  6464.         MOV     EAX,[ESP+EBX*4+5*4]
  6465.         MOV     EDX,ESI
  6466.         TEST    EAX,EAX
  6467.         JE      @@2
  6468.         MOV     ECX,[EAX-4]
  6469.         ADD     ESI,ECX
  6470.         CALL    Move
  6471. @@2:
  6472.         DEC     EBX
  6473.         JNE     @@loop2
  6474.  
  6475.         POP     EDX
  6476.         POP     EAX
  6477.         CALL    WStrSet
  6478.  
  6479.         POP     EDX
  6480.         POP     ESI
  6481.         POP     EBX
  6482.         POP     EAX
  6483.         LEA     ESP,[ESP+EDX*4]
  6484.         JMP     EAX
  6485. end;
  6486.  
  6487.  
  6488. procedure _WStrCmp{left: WideString; right: WideString};
  6489. asm
  6490. {     ->EAX = Pointer to left string    }
  6491. {       EDX = Pointer to right string   }
  6492.  
  6493.         PUSH    EBX
  6494.         PUSH    ESI
  6495.         PUSH    EDI
  6496.  
  6497.         MOV     ESI,EAX
  6498.         MOV     EDI,EDX
  6499.  
  6500.         CMP     EAX,EDX
  6501.         JE      @@exit
  6502.  
  6503.         TEST    ESI,ESI
  6504.         JE      @@str1null
  6505.  
  6506.         TEST    EDI,EDI
  6507.         JE      @@str2null
  6508.  
  6509.         MOV     EAX,[ESI-4]
  6510.         MOV     EDX,[EDI-4]
  6511.  
  6512.         SUB     EAX,EDX { eax = len1 - len2 }
  6513.         JA      @@skip1
  6514.         ADD     EDX,EAX { edx = len2 + (len1 - len2) = len1     }
  6515.  
  6516. @@skip1:
  6517.         PUSH    EDX
  6518.         SHR     EDX,2
  6519.         JE      @@cmpRest
  6520. @@longLoop:
  6521.         MOV     ECX,[ESI]
  6522.         MOV     EBX,[EDI]
  6523.         CMP     ECX,EBX
  6524.         JNE     @@misMatch
  6525.         DEC     EDX
  6526.         JE      @@cmpRestP4
  6527.         MOV     ECX,[ESI+4]
  6528.         MOV     EBX,[EDI+4]
  6529.         CMP     ECX,EBX
  6530.         JNE     @@misMatch
  6531.         ADD     ESI,8
  6532.         ADD     EDI,8
  6533.         DEC     EDX
  6534.         JNE     @@longLoop
  6535.         JMP     @@cmpRest
  6536. @@cmpRestP4:
  6537.         ADD     ESI,4
  6538.         ADD     EDI,4
  6539. @@cmpRest:
  6540.         POP     EDX
  6541.         AND     EDX,2
  6542.         JE      @@equal
  6543.  
  6544.         MOV     CX,[ESI]
  6545.         MOV     BX,[EDI]
  6546.         CMP     CX,BX
  6547.         JNE     @@exit
  6548.  
  6549. @@equal:
  6550.         ADD     EAX,EAX
  6551.         JMP     @@exit
  6552.  
  6553. @@str1null:
  6554.         MOV     EDX,[EDI-4]
  6555.         SUB     EAX,EDX
  6556.         JMP     @@exit
  6557.  
  6558. @@str2null:
  6559.         MOV     EAX,[ESI-4]
  6560.         SUB     EAX,EDX
  6561.         JMP     @@exit
  6562.  
  6563. @@misMatch:
  6564.         POP     EDX
  6565.         CMP     CX,BX
  6566.         JNE     @@exit
  6567.         SHR     ECX,16
  6568.         SHR     EBX,16
  6569.         CMP     CX,BX
  6570.  
  6571. @@exit:
  6572.         POP     EDI
  6573.         POP     ESI
  6574.         POP     EBX
  6575. end;
  6576.  
  6577.  
  6578. function _NewWideString(Length: Integer): PWideChar;
  6579. asm
  6580.         TEST    EAX,EAX
  6581.         JE      @@1
  6582.         PUSH    EAX
  6583.         PUSH    0
  6584.         CALL    SysAllocStringLen
  6585.         TEST    EAX,EAX
  6586.         JE      WStrError
  6587. @@1:
  6588. end;
  6589.  
  6590.  
  6591. function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
  6592. var
  6593.   L, N: Integer;
  6594. begin
  6595.   L := Length(S);
  6596.   if Index < 1 then Index := 0 else
  6597.   begin
  6598.     Dec(Index);
  6599.     if Index > L then Index := L;
  6600.   end;
  6601.   if Count < 0 then N := 0 else
  6602.   begin
  6603.     N := L - Index;
  6604.     if N > Count then N := Count;
  6605.   end;
  6606.   _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N);
  6607. end;
  6608.  
  6609.  
  6610. procedure _WStrDelete(var S: WideString; Index, Count: Integer);
  6611. var
  6612.   L, N: Integer;
  6613.   NewStr: PWideChar;
  6614. begin
  6615.   L := Length(S);
  6616.   if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then
  6617.   begin
  6618.     Dec(Index);
  6619.     N := L - Index - Count;
  6620.     if N < 0 then N := 0;
  6621.     if (Index = 0) and (N = 0) then NewStr := nil else
  6622.     begin
  6623.       NewStr := _NewWideString(Index + N);
  6624.       if Index > 0 then
  6625.         Move(Pointer(S)^, NewStr^, Index * 2);
  6626.       if N > 0 then
  6627.         Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2);
  6628.     end;
  6629.     WStrSet(S, NewStr);
  6630.   end;
  6631. end;
  6632.  
  6633.  
  6634. procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
  6635. var
  6636.   SourceLen, DestLen: Integer;
  6637.   NewStr: PWideChar;
  6638. begin
  6639.   SourceLen := Length(Source);
  6640.   if SourceLen > 0 then
  6641.   begin
  6642.     DestLen := Length(Dest);
  6643.     if Index < 1 then Index := 0 else
  6644.     begin
  6645.       Dec(Index);
  6646.       if Index > DestLen then Index := DestLen;
  6647.     end;
  6648.     NewStr := _NewWideString(DestLen + SourceLen);
  6649.     if Index > 0 then
  6650.       Move(Pointer(Dest)^, NewStr^, Index * 2);
  6651.     Move(Pointer(Source)^, NewStr[Index], SourceLen * 2);
  6652.     if Index < DestLen then
  6653.       Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen],
  6654.         (DestLen - Index) * 2);
  6655.     WStrSet(Dest, NewStr);
  6656.   end;
  6657. end;
  6658.  
  6659.  
  6660. procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
  6661. asm
  6662. {     ->EAX     Pointer to substr               }
  6663. {       EDX     Pointer to string               }
  6664. {     <-EAX     Position of substr in s or 0    }
  6665.  
  6666.         TEST    EAX,EAX
  6667.         JE      @@noWork
  6668.  
  6669.         TEST    EDX,EDX
  6670.         JE      @@stringEmpty
  6671.  
  6672.         PUSH    EBX
  6673.         PUSH    ESI
  6674.         PUSH    EDI
  6675.  
  6676.         MOV     ESI,EAX                         { Point ESI to substr           }
  6677.         MOV     EDI,EDX                         { Point EDI to s                }
  6678.  
  6679.         MOV     ECX,[EDI-4]                     { ECX = Length(s)               }
  6680.         SHR     ECX,1
  6681.  
  6682.         PUSH    EDI                             { remember s position to calculate index        }
  6683.  
  6684.         MOV     EDX,[ESI-4]                     { EDX = Length(substr)          }
  6685.         SHR     EDX,1
  6686.  
  6687.         DEC     EDX                             { EDX = Length(substr) - 1              }
  6688.         JS      @@fail                          { < 0 ? return 0                        }
  6689.         MOV     AX,[ESI]                        { AL = first char of substr             }
  6690.         ADD     ESI,2                           { Point ESI to 2'nd char of substr      }
  6691.  
  6692.         SUB     ECX,EDX                         { #positions in s to look at    }
  6693.                                                 { = Length(s) - Length(substr) + 1      }
  6694.         JLE     @@fail
  6695. @@loop:
  6696.         REPNE   SCASW
  6697.         JNE     @@fail
  6698.         MOV     EBX,ECX                         { save outer loop counter               }
  6699.         PUSH    ESI                             { save outer loop substr pointer        }
  6700.         PUSH    EDI                             { save outer loop s pointer             }
  6701.  
  6702.         MOV     ECX,EDX
  6703.         REPE    CMPSW
  6704.         POP     EDI                             { restore outer loop s pointer  }
  6705.         POP     ESI                             { restore outer loop substr pointer     }
  6706.         JE      @@found
  6707.         MOV     ECX,EBX                         { restore outer loop counter    }
  6708.         JMP     @@loop
  6709.  
  6710. @@fail:
  6711.         POP     EDX                             { get rid of saved s pointer    }
  6712.         XOR     EAX,EAX
  6713.         JMP     @@exit
  6714.  
  6715. @@stringEmpty:
  6716.         XOR     EAX,EAX
  6717.         JMP     @@noWork
  6718.  
  6719. @@found:
  6720.         POP     EDX                             { restore pointer to first char of s    }
  6721.         MOV     EAX,EDI                         { EDI points of char after match        }
  6722.         SUB     EAX,EDX                         { the difference is the correct index   }
  6723.         SHR     EAX,1
  6724. @@exit:
  6725.         POP     EDI
  6726.         POP     ESI
  6727.         POP     EBX
  6728. @@noWork:
  6729. end;
  6730.  
  6731.  
  6732. procedure _WStrSetLength(var S: WideString; NewLength: Integer);
  6733. var
  6734.   NewStr: PWideChar;
  6735.   Count: Integer;
  6736. begin
  6737.   NewStr := nil;
  6738.   if NewLength > 0 then
  6739.   begin
  6740.     NewStr := _NewWideString(NewLength);
  6741.     Count := Length(S);
  6742.     if Count > 0 then
  6743.     begin
  6744.       if Count > NewLength then Count := NewLength;
  6745.       Move(Pointer(S)^, NewStr^, Count * 2);
  6746.     end;
  6747.   end;
  6748.   WStrSet(S, NewStr);
  6749. end;
  6750.  
  6751.  
  6752. function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
  6753. var
  6754.   P: PWideChar;
  6755. begin
  6756.   _WStrFromPWCharLen(Result, nil, Count);
  6757.   P := Pointer(Result);
  6758.   while Count > 0 do
  6759.   begin
  6760.     Dec(Count);
  6761.     P[Count] := Ch;
  6762.   end;
  6763. end;
  6764.  
  6765.  
  6766. procedure _WStrAddRef{var str: WideString};
  6767. asm
  6768.         MOV     EDX,[EAX]
  6769.         TEST    EDX,EDX
  6770.         JE      @@1
  6771.         PUSH    EAX
  6772.         MOV     ECX,[EDX-4]
  6773.         SHR     ECX,1
  6774.         PUSH    ECX
  6775.         PUSH    EDX
  6776.         CALL    SysAllocStringLen
  6777.         POP     EDX
  6778.         TEST    EAX,EAX
  6779.         JE      WStrError
  6780.         MOV     [EDX],EAX
  6781. @@1:
  6782. end;
  6783.  
  6784.  
  6785. procedure       _InitializeRecord{ p: Pointer; typeInfo: Pointer };
  6786. asm
  6787.         { ->    EAX pointer to record to be finalized   }
  6788.         {       EDX pointer to type info                }
  6789.  
  6790.         XOR     ECX,ECX
  6791.  
  6792.         PUSH    EBX
  6793.         MOV     CL,[EDX+1]
  6794.  
  6795.         PUSH    ESI
  6796.         PUSH    EDI
  6797.  
  6798.         MOV     EBX,EAX
  6799.         LEA     ESI,[EDX+ECX+2+8]
  6800.         MOV     EDI,[EDX+ECX+2+4]
  6801.  
  6802. @@loop:
  6803.  
  6804.         MOV     EDX,[ESI]
  6805.         MOV     EAX,[ESI+4]
  6806.         ADD     EAX,EBX
  6807.         MOV     EDX,[EDX]
  6808.         CALL    _Initialize
  6809.         ADD     ESI,8
  6810.         DEC     EDI
  6811.         JG      @@loop
  6812.  
  6813.         POP     EDI
  6814.         POP     ESI
  6815.         POP     EBX
  6816. end;
  6817.  
  6818.  
  6819. const
  6820.   tkLString   = 10;
  6821.   tkWString   = 11;
  6822.   tkVariant   = 12;
  6823.   tkArray     = 13;
  6824.   tkRecord    = 14;
  6825.   tkInterface = 15;
  6826.  
  6827. procedure       _InitializeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  6828. asm
  6829.         { ->    EAX     pointer to data to be finalized         }
  6830.         {       EDX     pointer to type info describing data    }
  6831.         {       ECX number of elements of that type             }
  6832.  
  6833.         PUSH    EBX
  6834.         PUSH    ESI
  6835.         PUSH    EDI
  6836.         MOV     EBX,EAX
  6837.         MOV     ESI,EDX
  6838.         MOV     EDI,ECX
  6839.  
  6840.         XOR     EDX,EDX
  6841.         MOV     AL,[ESI]
  6842.         MOV     DL,[ESI+1]
  6843.         XOR     ECX,ECX
  6844.  
  6845.         CMP     AL,tkLString
  6846.         JE      @@LString
  6847.         CMP     AL,tkWString
  6848.         JE      @@WString
  6849.         CMP     AL,tkVariant
  6850.         JE      @@Variant
  6851.         CMP     AL,tkArray
  6852.         JE      @@Array
  6853.         CMP     AL,tkRecord
  6854.         JE      @@Record
  6855.         CMP     AL,tkInterface
  6856.         JE      @@Interface
  6857.         MOV     AL,reInvalidPtr
  6858.         POP     EDI
  6859.         POP     ESI
  6860.         POP     EBX
  6861.         JMP     Error
  6862.  
  6863. @@LString:
  6864. @@WString:
  6865. @@Interface:
  6866.         MOV     [EBX],ECX
  6867.         ADD     EBX,4
  6868.         DEC     EDI
  6869.         JG      @@LString
  6870.         JMP     @@exit
  6871.  
  6872. @@Variant:
  6873.         MOV     [EBX   ],ECX
  6874.         MOV     [EBX+ 4],ECX
  6875.         MOV     [EBX+ 8],ECX
  6876.         MOV     [EBX+12],ECX
  6877.         ADD     EBX,16
  6878.         DEC     EDI
  6879.         JG      @@Variant
  6880.         JMP     @@exit
  6881.  
  6882. @@Array:
  6883.         PUSH    EBP
  6884.         MOV     EBP,EDX
  6885. @@ArrayLoop:
  6886.         MOV     EDX,[ESI+EBP+2+8]
  6887.         MOV     EAX,EBX
  6888.         ADD     EBX,[ESI+EBP+2]
  6889.         MOV     ECX,[ESI+EBP+2+4]
  6890.         MOV     EDX,[EDX]
  6891.         CALL    _InitializeArray
  6892.         DEC     EDI
  6893.         JG      @@ArrayLoop
  6894.         POP     EBP
  6895.         JMP     @@exit
  6896.  
  6897. @@Record:
  6898.         PUSH    EBP
  6899.         MOV     EBP,EDX
  6900. @@RecordLoop:
  6901.         MOV     EAX,EBX
  6902.         ADD     EBX,[ESI+EBP+2]
  6903.         MOV     EDX,ESI
  6904.         CALL    _InitializeRecord
  6905.         DEC     EDI
  6906.         JG      @@RecordLoop
  6907.         POP     EBP
  6908.  
  6909. @@exit:
  6910.  
  6911.         POP     EDI
  6912.         POP     ESI
  6913.     POP EBX
  6914. end;
  6915.  
  6916.  
  6917. procedure       _Initialize{ p: Pointer; typeInfo: Pointer};
  6918. asm
  6919.         MOV     ECX,1
  6920.         JMP     _InitializeArray
  6921. end;
  6922.  
  6923. procedure       _FinalizeRecord{ p: Pointer; typeInfo: Pointer };
  6924. asm
  6925.         { ->    EAX pointer to record to be finalized   }
  6926.         {       EDX pointer to type info                }
  6927.  
  6928.         XOR     ECX,ECX
  6929.  
  6930.         PUSH    EBX
  6931.         MOV     CL,[EDX+1]
  6932.  
  6933.         PUSH    ESI
  6934.         PUSH    EDI
  6935.  
  6936.         MOV     EBX,EAX
  6937.         LEA     ESI,[EDX+ECX+2+8]
  6938.         MOV     EDI,[EDX+ECX+2+4]
  6939.  
  6940. @@loop:
  6941.  
  6942.         MOV     EDX,[ESI]
  6943.         MOV     EAX,[ESI+4]
  6944.         ADD     EAX,EBX
  6945.         MOV     EDX,[EDX]
  6946.         CALL    _Finalize
  6947.         ADD     ESI,8
  6948.         DEC     EDI
  6949.         JG      @@loop
  6950.  
  6951.         MOV     EAX,EBX
  6952.  
  6953.         POP     EDI
  6954.         POP     ESI
  6955.         POP     EBX
  6956. end;
  6957.  
  6958.  
  6959. procedure       _FinalizeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  6960. asm
  6961.         { ->    EAX     pointer to data to be finalized         }
  6962.         {       EDX     pointer to type info describing data    }
  6963.         {       ECX number of elements of that type             }
  6964.  
  6965.         PUSH    EAX
  6966.         PUSH    EBX
  6967.         PUSH    ESI
  6968.         PUSH    EDI
  6969.         MOV     EBX,EAX
  6970.         MOV     ESI,EDX
  6971.         MOV     EDI,ECX
  6972.  
  6973.         XOR     EDX,EDX
  6974.         MOV     AL,[ESI]
  6975.         MOV     DL,[ESI+1]
  6976.  
  6977.         CMP     AL,tkLString
  6978.         JE      @@LString
  6979.         CMP     AL,tkWString
  6980.         JE      @@WString
  6981.         CMP     AL,tkVariant
  6982.         JE      @@Variant
  6983.         CMP     AL,tkArray
  6984.         JE      @@Array
  6985.         CMP     AL,tkRecord
  6986.         JE      @@Record
  6987.         CMP     AL,tkInterface
  6988.         JE      @@Interface
  6989.         POP     EDI
  6990.         POP     ESI
  6991.         POP     EBX
  6992.         POP      EAX
  6993.         MOV     AL,reInvalidPtr
  6994.         JMP     Error
  6995.  
  6996. @@LString:
  6997.         CMP     ECX,1
  6998.         MOV     EAX,EBX
  6999.         JG      @@LStringArray
  7000.         CALL    _LStrClr
  7001.         JMP     @@exit
  7002. @@LStringArray:
  7003.         MOV     EDX,ECX
  7004.         CALL    _LStrArrayClr
  7005.         JMP     @@exit
  7006.  
  7007. @@WString:
  7008.         CMP     ECX,1
  7009.         MOV     EAX,EBX
  7010.         JG      @@WStringArray
  7011.         CALL    _WStrClr
  7012.         JMP     @@exit
  7013. @@WStringArray:
  7014.         MOV     EDX,ECX
  7015.         CALL    _WStrArrayClr
  7016.         JMP     @@exit
  7017.  
  7018. @@Variant:
  7019.                 MOV     EAX,EBX
  7020.                 ADD     EBX,16
  7021.         CALL    _VarClr
  7022.         DEC     EDI
  7023.         JG      @@Variant
  7024.         JMP     @@exit
  7025.  
  7026. @@Array:
  7027.         PUSH    EBP
  7028.         MOV     EBP,EDX
  7029. @@ArrayLoop:
  7030.         MOV     EDX,[ESI+EBP+2+8]
  7031.         MOV     EAX,EBX
  7032.         ADD     EBX,[ESI+EBP+2]
  7033.         MOV     ECX,[ESI+EBP+2+4]
  7034.         MOV     EDX,[EDX]
  7035.         CALL    _FinalizeArray
  7036.         DEC     EDI
  7037.         JG      @@ArrayLoop
  7038.         POP     EBP
  7039.         JMP     @@exit
  7040.  
  7041. @@Record:
  7042.         PUSH    EBP
  7043.         MOV     EBP,EDX
  7044. @@RecordLoop:
  7045.         MOV     EAX,EBX
  7046.         ADD     EBX,[ESI+EBP+2]
  7047.         MOV     EDX,ESI
  7048.         CALL    _FinalizeRecord
  7049.         DEC     EDI
  7050.         JG      @@RecordLoop
  7051.         POP     EBP
  7052.         JMP     @@exit
  7053.  
  7054. @@Interface:
  7055.         MOV     EAX,EBX
  7056.         ADD     EBX,4
  7057.         CALL    _IntfClear
  7058.         DEC     EDI
  7059.         JG      @@Interface
  7060. @@exit:
  7061.  
  7062.         POP     EDI
  7063.         POP     ESI
  7064.         POP     EBX
  7065.         POP     EAX
  7066. end;
  7067.  
  7068.  
  7069. procedure       _Finalize{ p: Pointer; typeInfo: Pointer};
  7070. asm
  7071.         MOV     ECX,1
  7072.         JMP     _FinalizeArray
  7073. end;
  7074.  
  7075. procedure       _AddRefRecord{ p: Pointer; typeInfo: Pointer };
  7076. asm
  7077.         { ->    EAX pointer to record to be finalized           }
  7078.         {       EDX pointer to type info        }
  7079.  
  7080.         XOR     ECX,ECX
  7081.  
  7082.         PUSH    EBX
  7083.         MOV     CL,[EDX+1]
  7084.  
  7085.         PUSH    ESI
  7086.         PUSH    EDI
  7087.  
  7088.         MOV     EBX,EAX
  7089.         LEA     ESI,[EDX+ECX+2+8]
  7090.         MOV     EDI,[EDX+ECX+2+4]
  7091.  
  7092. @@loop:
  7093.  
  7094.         MOV     EDX,[ESI]
  7095.         MOV     EAX,[ESI+4]
  7096.         ADD     EAX,EBX
  7097.         MOV     EDX,[EDX]
  7098.         CALL    _AddRef
  7099.         ADD     ESI,8
  7100.         DEC     EDI
  7101.         JG      @@loop
  7102.  
  7103.         POP     EDI
  7104.         POP     ESI
  7105.         POP     EBX
  7106. end;
  7107.  
  7108.  
  7109. procedure       _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
  7110. asm
  7111.         { ->    EAX     pointer to data to be finalized         }
  7112.         {       EDX     pointer to type info describing data    }
  7113.         {       ECX number of elements of that type             }
  7114.  
  7115.         PUSH    EBX
  7116.         PUSH    ESI
  7117.         PUSH    EDI
  7118.         MOV     EBX,EAX
  7119.         MOV     ESI,EDX
  7120.         MOV     EDI,ECX
  7121.  
  7122.         XOR     EDX,EDX
  7123.         MOV     AL,[ESI]
  7124.         MOV     DL,[ESI+1]
  7125.  
  7126.         CMP     AL,tkLString
  7127.         JE      @@LString
  7128.         CMP     AL,tkWString
  7129.         JE      @@WString
  7130.         CMP     AL,tkVariant
  7131.         JE      @@Variant
  7132.         CMP     AL,tkArray
  7133.         JE      @@Array
  7134.         CMP     AL,tkRecord
  7135.         JE      @@Record
  7136.         CMP     AL,tkInterface
  7137.         JE      @@Interface
  7138.         MOV     AL,reInvalidPtr
  7139.         POP     EDI
  7140.         POP     ESI
  7141.         POP     EBX
  7142.         JMP     Error
  7143.  
  7144. @@LString:
  7145.         MOV     EAX,[EBX]
  7146.         ADD     EBX,4
  7147.         CALL    _LStrAddRef
  7148.         DEC     EDI
  7149.         JG      @@LString
  7150.         JMP     @@exit
  7151.  
  7152. @@WString:
  7153.         MOV     EAX,EBX
  7154.         ADD     EBX,4
  7155.         CALL    _WStrAddRef
  7156.         DEC     EDI
  7157.         JG      @@WString
  7158.         JMP     @@exit
  7159.  
  7160. @@Variant:
  7161.         MOV     EAX,EBX
  7162.         ADD     EBX,16
  7163.         CALL    _VarAddRef
  7164.         DEC     EDI
  7165.         JG      @@Variant
  7166.         JMP     @@exit
  7167.  
  7168. @@Array:
  7169.         PUSH    EBP
  7170.         MOV     EBP,EDX
  7171. @@ArrayLoop:
  7172.         MOV     EDX,[ESI+EBP+2+8]
  7173.         MOV     EAX,EBX
  7174.         ADD     EBX,[ESI+EBP+2]
  7175.         MOV     ECX,[ESI+EBP+2+4]
  7176.         MOV     EDX,[EDX]
  7177.         CALL    _AddRefArray
  7178.         DEC     EDI
  7179.         JG      @@ArrayLoop
  7180.         POP     EBP
  7181.         JMP     @@exit
  7182.  
  7183. @@Record:
  7184.         PUSH    EBP
  7185.         MOV     EBP,EDX
  7186. @@RecordLoop:
  7187.         MOV     EAX,EBX
  7188.         ADD     EBX,[ESI+EBP+2]
  7189.         MOV     EDX,ESI
  7190.         CALL    _AddRefRecord
  7191.         DEC     EDI
  7192.         JG      @@RecordLoop
  7193.         POP     EBP
  7194.         JMP     @@exit
  7195.  
  7196. @@Interface:
  7197.         MOV     EAX,[EBX]
  7198.         ADD     EBX,4
  7199.         CALL    _IntfAddRef
  7200.         DEC     EDI
  7201.         JG      @@Interface
  7202. @@exit:
  7203.  
  7204.         POP     EDI
  7205.         POP     ESI
  7206.         POP     EBX
  7207. end;
  7208.  
  7209.  
  7210. procedure       _AddRef{ p: Pointer; typeInfo: Pointer};
  7211. asm
  7212.         MOV     ECX,1
  7213.         JMP     _AddRefArray
  7214. end;
  7215.  
  7216.  
  7217. procedure       _CopyRecord{ dest, source, typeInfo: Pointer };
  7218. asm
  7219.         { ->    EAX pointer to dest             }
  7220.         {       EDX pointer to source           }
  7221.         {       ECX pointer to typeInfo         }
  7222.  
  7223.         PUSH    EBX
  7224.         PUSH    ESI
  7225.         PUSH    EDI
  7226.         PUSH    EBP
  7227.  
  7228.         MOV     EBX,EAX
  7229.         MOV     ESI,EDX
  7230.  
  7231.         XOR     EAX,EAX
  7232.         MOV     AL,[ECX+1]
  7233.  
  7234.         LEA     EDI,[ECX+EAX+2+8]
  7235.         MOV     EBP,[EDI-4]
  7236.         XOR     EAX,EAX
  7237.         MOV     ECX,[EDI-8]
  7238.         PUSH    ECX
  7239. @@loop:
  7240.         MOV     ECX,[EDI+4]
  7241.         SUB     ECX,EAX
  7242.         JLE     @@nomove1
  7243.         MOV     EDX,EAX
  7244.         ADD     EAX,ESI
  7245.         ADD     EDX,EBX
  7246.         CALL    Move
  7247. @@noMove1:
  7248.         MOV     EAX,[EDI+4]
  7249.  
  7250.         MOV     EDX,[EDI]
  7251.         MOV     EDX,[EDX]
  7252.         MOV     CL,[EDX]
  7253.         
  7254.         CMP     CL,tkLString
  7255.         JE      @@LString
  7256.         CMP     CL,tkWString
  7257.         JE      @@WString
  7258.         CMP     CL,tkVariant
  7259.         JE      @@Variant
  7260.         CMP     CL,tkArray
  7261.         JE      @@Array
  7262.         CMP     CL,tkRecord
  7263.         JE      @@Record
  7264.         CMP     CL,tkInterface
  7265.         JE      @@Interface
  7266.         MOV     AL,reInvalidPtr
  7267.         POP     EBP
  7268.         POP     EDI
  7269.         POP     ESI
  7270.         POP     EBX
  7271.         JMP     Error
  7272.  
  7273. @@LString:
  7274.         MOV     EDX,[ESI+EAX]
  7275.         ADD     EAX,EBX
  7276.         CALL    _LStrAsg
  7277.         MOV     EAX,4
  7278.         JMP     @@common
  7279.  
  7280. @@WString:
  7281.         MOV     EDX,[ESI+EAX]
  7282.         ADD     EAX,EBX
  7283.         CALL    _WStrAsg
  7284.         MOV     EAX,4
  7285.         JMP     @@common
  7286.  
  7287. @@Variant:
  7288.         LEA     EDX,[ESI+EAX]
  7289.         ADD     EAX,EBX
  7290.         CALL    _VarCopy
  7291.         MOV     EAX,16
  7292.         JMP     @@common
  7293.  
  7294. @@Array:
  7295.         XOR     ECX,ECX
  7296.         MOV     CL,[EDX+1]
  7297.         PUSH    dword ptr [EDX+ECX+2]
  7298.         PUSH    dword ptr [EDX+ECX+2+4]
  7299.         MOV     ECX,[EDX+ECX+2+8]
  7300.         MOV     ECX,[ECX]
  7301.         LEA     EDX,[ESI+EAX]
  7302.         ADD     EAX,EBX
  7303.         CALL    _CopyArray
  7304.         POP     EAX
  7305.         JMP     @@common
  7306.  
  7307. @@Record:
  7308.         XOR     ECX,ECX
  7309.         MOV     CL,[EDX+1]
  7310.         MOV     ECX,[EDX+ECX+2]
  7311.         PUSH    ECX
  7312.         MOV     ECX,EDX
  7313.         LEA     EDX,[ESI+EAX]
  7314.         ADD     EAX,EBX
  7315.         CALL    _CopyRecord
  7316.         POP     EAX
  7317.         JMP     @@common
  7318.  
  7319. @@Interface:
  7320.         MOV     EDX,[ESI+EAX]
  7321.         ADD     EAX,EBX
  7322.         CALL    _IntfCopy
  7323.         MOV     EAX,4
  7324. @@common:
  7325.         ADD     EAX,[EDI+4]
  7326.         ADD     EDI,8
  7327.         DEC     EBP
  7328.         JNZ     @@loop
  7329.  
  7330.         POP     ECX
  7331.         SUB     ECX,EAX
  7332.         JLE     @@noMove2
  7333.         LEA     EDX,[EBX+EAX]
  7334.         ADD     EAX,ESI
  7335.         CALL    Move
  7336. @@noMove2:
  7337.  
  7338.         POP     EBP
  7339.         POP     EDI
  7340.         POP     ESI
  7341.         POP     EBX
  7342. end;
  7343.  
  7344.  
  7345. procedure       _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer };
  7346. asm
  7347.         { ->    EAX pointer to dest             }
  7348.         {       EDX pointer to source           }
  7349.         {       ECX offset of vmt in object     }
  7350.         {       [ESP+4] pointer to typeInfo     }
  7351.  
  7352.         ADD     ECX,EAX                         { pointer to dest vmt }
  7353.         PUSH    dword ptr [ECX]                 { save dest vmt }
  7354.         PUSH    ECX
  7355.         MOV     ECX,[ESP+4+4+4]
  7356.         CALL    _CopyRecord
  7357.         POP     ECX
  7358.         POP     dword ptr [ECX]                 { restore dest vmt }
  7359.         RET     4
  7360.  
  7361. end;
  7362.  
  7363. procedure       _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer };
  7364. asm
  7365.         { ->    EAX pointer to dest             }
  7366.         {       EDX pointer to source           }
  7367.         {       ECX pointer to typeInfo         }
  7368.         {       [ESP+4] count                   }
  7369.         PUSH    EBX
  7370.         PUSH    ESI
  7371.         PUSH    EDI
  7372.         PUSH    EBP
  7373.  
  7374.         MOV     EBX,EAX
  7375.         MOV     ESI,EDX
  7376.         MOV     EDI,ECX
  7377.         MOV     EBP,[ESP+4+4*4]
  7378.  
  7379.         MOV     CL,[EDI]
  7380.  
  7381.         CMP     CL,tkLString
  7382.         JE      @@LString
  7383.         CMP     CL,tkWString
  7384.         JE      @@WString
  7385.         CMP     CL,tkVariant
  7386.         JE      @@Variant
  7387.         CMP     CL,tkArray
  7388.         JE      @@Array
  7389.         CMP     CL,tkRecord
  7390.         JE      @@Record
  7391.         CMP     CL,tkInterface
  7392.         JE      @@Interface
  7393.         MOV     AL,reInvalidPtr
  7394.         POP     EBP
  7395.         POP     EDI
  7396.         POP     ESI
  7397.         POP     EBX
  7398.         JMP     Error
  7399.  
  7400. @@LString:
  7401.         MOV     EAX,EBX
  7402.         MOV     EDX,[ESI]
  7403.         CALL    _LStrAsg
  7404.         ADD     EBX,4
  7405.         ADD     ESI,4
  7406.         DEC     EBP
  7407.         JNE     @@LString
  7408.         JMP     @@exit
  7409.  
  7410. @@WString:
  7411.         MOV     EAX,EBX
  7412.         MOV     EDX,[ESI]
  7413.         CALL    _WStrAsg
  7414.         ADD     EBX,4
  7415.         ADD     ESI,4
  7416.         DEC     EBP
  7417.         JNE     @@WString
  7418.         JMP     @@exit
  7419.  
  7420. @@Variant:
  7421.         MOV     EAX,EBX
  7422.         MOV     EDX,ESI
  7423.         CALL    _VarCopy
  7424.         ADD     EBX,16
  7425.         ADD     ESI,16
  7426.         DEC     EBP
  7427.         JNE     @@Variant
  7428.         JMP     @@exit
  7429.  
  7430. @@Array:
  7431.         XOR     ECX,ECX
  7432.         MOV     CL,[EDI+1]
  7433.         LEA     EDI,[EDI+ECX+2]
  7434. @@ArrayLoop:
  7435.         MOV     EAX,EBX
  7436.         MOV     EDX,ESI
  7437.         MOV     ECX,[EDI+8]
  7438.         PUSH    dword ptr [EDI+4]
  7439.         CALL    _CopyArray
  7440.         ADD     EBX,[EDI]
  7441.         ADD     ESI,[EDI]
  7442.         DEC     EBP
  7443.         JNE     @@ArrayLoop
  7444.         JMP     @@exit
  7445.  
  7446. @@Record:
  7447.         MOV     EAX,EBX
  7448.         MOV     EDX,ESI
  7449.         MOV     ECX,EDI
  7450.         CALL    _CopyRecord
  7451.         XOR     EAX,EAX
  7452.         MOV     AL,[EDI+1]
  7453.         ADD     EBX,[EDI+EAX+2]
  7454.         ADD     ESI,[EDI+EAX+2]
  7455.         DEC     EBP
  7456.         JNE     @@Record
  7457.         JMP     @@exit
  7458.  
  7459. @@Interface:
  7460.         MOV     EAX,EBX
  7461.         MOV     EDX,[ESI]
  7462.         CALL    _IntfCopy
  7463.         ADD     EBX,4
  7464.         ADD     ESI,4
  7465.         DEC     EBP
  7466.         JNE     @@Interface
  7467. @@exit:
  7468.         POP     EBP
  7469.         POP     EDI
  7470.         POP     ESI
  7471.         POP     EBX
  7472.         RET     4
  7473. end;
  7474.  
  7475.  
  7476. procedure       _New{ size: Longint; typeInfo: Pointer};
  7477. asm
  7478.         { ->    EAX size of object to allocate  }
  7479.         {       EDX pointer to typeInfo         }
  7480.  
  7481.         PUSH    EDX
  7482.         CALL    _GetMem
  7483.         POP     EDX
  7484.         TEST    EAX,EAX
  7485.         JE      @@exit
  7486.         PUSH    EAX
  7487.         CALL    _Initialize
  7488.         POP     EAX
  7489. @@exit:
  7490. end;
  7491.  
  7492. procedure       _Dispose{ p: Pointer; typeInfo: Pointer};
  7493. asm
  7494.         { ->    EAX     Pointer to object to be disposed        }
  7495.         {       EDX     Pointer to type info            }
  7496.  
  7497.         PUSH    EAX
  7498.         CALL    _Finalize
  7499.         POP     EAX
  7500.         CALL    _FreeMem
  7501. end;
  7502.  
  7503. { ----------------------------------------------------- }
  7504. {       Wide character support                          }
  7505. { ----------------------------------------------------- }
  7506.  
  7507. function WideCharToString(Source: PWideChar): string;
  7508. begin
  7509.   WideCharToStrVar(Source, Result);
  7510. end;
  7511.  
  7512. function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
  7513. begin
  7514.   WideCharLenToStrVar(Source, SourceLen, Result);
  7515. end;
  7516.  
  7517. procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
  7518. var
  7519.   SourceLen: Integer;
  7520. begin
  7521.   SourceLen := 0;
  7522.   while Source[SourceLen] <> #0 do Inc(SourceLen);
  7523.   WideCharLenToStrVar(Source, SourceLen, Dest);
  7524. end;
  7525.  
  7526. procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
  7527.   var Dest: string);
  7528. var
  7529.   DestLen: Integer;
  7530.   Buffer: array[0..2047] of Char;
  7531. begin
  7532.   if SourceLen = 0 then
  7533.     Dest := ''
  7534.   else
  7535.     if SourceLen < SizeOf(Buffer) div 2 then
  7536.       SetString(Dest, Buffer, WideCharToMultiByte(0, 0,
  7537.         Source, SourceLen, Buffer, SizeOf(Buffer), nil, nil))
  7538.     else
  7539.     begin
  7540.       DestLen := WideCharToMultiByte(0, 0, Source, SourceLen,
  7541.         nil, 0, nil, nil);
  7542.       SetString(Dest, nil, DestLen);
  7543.       WideCharToMultiByte(0, 0, Source, SourceLen, Pointer(Dest),
  7544.         DestLen, nil, nil);
  7545.     end;
  7546. end;
  7547.  
  7548. function StringToWideChar(const Source: string; Dest: PWideChar;
  7549.   DestSize: Integer): PWideChar;
  7550. begin
  7551.   Dest[MultiByteToWideChar(0, 0, PChar(Source), Length(Source),
  7552.     Dest, DestSize - 1)] := #0;
  7553.   Result := Dest;
  7554. end;
  7555.  
  7556. { ----------------------------------------------------- }
  7557. {       OLE string support                              }
  7558. { ----------------------------------------------------- }
  7559.  
  7560. function OleStrToString(Source: PWideChar): string;
  7561. begin
  7562.   OleStrToStrVar(Source, Result);
  7563. end;
  7564.  
  7565. procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
  7566. begin
  7567.   WideCharLenToStrVar(Source, SysStringLen(WideString(Pointer(Source))), Dest);
  7568. end;
  7569.  
  7570. function StringToOleStr(const Source: string): PWideChar;
  7571. var
  7572.   SourceLen, ResultLen: Integer;
  7573.   Buffer: array[0..1023] of WideChar;
  7574. begin
  7575.   SourceLen := Length(Source);
  7576.   if Length(Source) < SizeOf(Buffer) div 2 then
  7577.     Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
  7578.       PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
  7579.   else
  7580.   begin
  7581.     ResultLen := MultiByteToWideChar(0, 0,
  7582.       Pointer(Source), SourceLen, nil, 0);
  7583.     Result := SysAllocStringLen(nil, ResultLen);
  7584.     MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
  7585.       Result, ResultLen);
  7586.   end;
  7587. end;
  7588.  
  7589. { ----------------------------------------------------- }
  7590. {       Variant support                                 }
  7591. { ----------------------------------------------------- }
  7592.  
  7593. type
  7594.   TBaseType = (btErr, btNul, btInt, btFlt, btCur, btStr, btBol, btDat);
  7595.  
  7596. const
  7597.   varLast = varByte;
  7598.  
  7599. const
  7600.   BaseTypeMap: array[0..varLast] of TBaseType = (
  7601.     btErr,  { varEmpty }
  7602.     btNul,  { varNull }
  7603.     btInt,  { varSmallint }
  7604.     btInt,  { varInteger }
  7605.     btFlt,  { varSingle }
  7606.     btFlt,  { varDouble }
  7607.     btCur,  { varCurrency }
  7608.     btDat,  { varDate }
  7609.     btStr,  { varOleStr }
  7610.     btErr,  { varDispatch }
  7611.     btErr,  { varError }
  7612.     btBol,  { varBoolean }
  7613.     btErr,  { varVariant }
  7614.     btErr,  { varUnknown }
  7615.     btErr,  { Undefined }
  7616.     btErr,  { Undefined }
  7617.     btErr,  { Undefined }
  7618.     btInt); { varByte }
  7619.  
  7620. const
  7621.   OpTypeMap: array[TBaseType, TBaseType] of TBaseType = (
  7622.     (btErr, btErr, btErr, btErr, btErr, btErr, btErr, btErr),
  7623.     (btErr, btNul, btNul, btNul, btNul, btNul, btNul, btNul),
  7624.     (btErr, btNul, btInt, btFlt, btCur, btFlt, btInt, btDat),
  7625.     (btErr, btNul, btFlt, btFlt, btCur, btFlt, btFlt, btDat),
  7626.     (btErr, btNul, btCur, btCur, btCur, btCur, btCur, btDat),
  7627.     (btErr, btNul, btFlt, btFlt, btCur, btStr, btBol, btDat),
  7628.     (btErr, btNul, btInt, btFlt, btCur, btBol, btBol, btDat),
  7629.     (btErr, btNul, btDat, btDat, btDat, btDat, btDat, btDat));
  7630.  
  7631. const
  7632.   C10000: Single = 10000;
  7633.  
  7634. const
  7635.   opAdd  = 0;
  7636.   opSub  = 1;
  7637.   opMul  = 2;
  7638.   opDvd  = 3;
  7639.   opDiv  = 4;
  7640.   opMod  = 5;
  7641.   opShl  = 6;
  7642.   opShr  = 7;
  7643.   opAnd  = 8;
  7644.   opOr   = 9;
  7645.   opXor  = 10;
  7646.  
  7647. procedure _DispInvoke;
  7648. asm
  7649.         { ->    [ESP+4] Pointer to result or nil }
  7650.         {       [ESP+8] Pointer to variant }
  7651.         {       [ESP+12]        Pointer to call descriptor }
  7652.         {       [ESP+16]        Additional parameters, if any }
  7653.         JMP     VarDispProc
  7654. end;
  7655.  
  7656.  
  7657. procedure _DispInvokeError;
  7658. asm
  7659.         MOV     AL,reVarDispatch
  7660.         JMP     Error
  7661. end;
  7662.  
  7663. procedure VarCastError;
  7664. asm
  7665.         MOV     AL,reVarTypeCast
  7666.         JMP     Error
  7667. end;
  7668.  
  7669. procedure VarInvalidOp;
  7670. asm
  7671.         MOV     AL,reVarInvalidOp
  7672.         JMP     Error
  7673. end;
  7674.  
  7675. procedure VarClear(var V);
  7676. asm
  7677.         XOR     EDX,EDX
  7678.         MOV     DX,[EAX].TVarData.VType
  7679.         TEST    EDX,varByRef
  7680.         JNE     @@1
  7681.         CMP     EDX,varOleStr
  7682.         JB      @@1
  7683.         CMP     EDX,varString
  7684.         JNE     @@2
  7685.         MOV     [EAX].TVarData.VType,varEmpty
  7686.         ADD     EAX,OFFSET TVarData.VString
  7687.         JMP     _LStrClr
  7688. @@1:    MOV     [EAX].TVarData.VType,varEmpty
  7689.         RET
  7690. @@2:    PUSH    EAX
  7691.         CALL    VariantClear
  7692. end;
  7693.  
  7694. procedure VarCopy(var Dest; const Source: Variant);
  7695. asm
  7696.         CMP     EAX,EDX
  7697.         JE      @@7
  7698.         CMP     [EAX].TVarData.VType,varOleStr
  7699.         JB      @@3
  7700.         PUSH    EAX
  7701.         PUSH    EDX
  7702.         CMP     [EAX].TVarData.VType,varString
  7703.         JE      @@1
  7704.         PUSH    EAX
  7705.         CALL    VariantClear
  7706.         JMP     @@2
  7707. @@1:    ADD     EAX,OFFSET TVarData.VString
  7708.         CALL    _LStrClr
  7709. @@2:    POP     EDX
  7710.         POP     EAX
  7711. @@3:    CMP     [EDX].TVarData.VType,varOleStr
  7712.         JAE     @@4
  7713.         MOV     ECX,[EDX]
  7714.         MOV     [EAX],ECX
  7715.         MOV     ECX,[EDX+8]
  7716.         MOV     [EAX+8],ECX
  7717.         MOV     ECX,[EDX+12]
  7718.         MOV     [EAX+12],ECX
  7719.         RET
  7720. @@4:    CMP     [EDX].TVarData.VType,varString
  7721.         JNE     @@6
  7722.         MOV     EDX,[EDX].TVarData.VString
  7723.         OR      EDX,EDX
  7724.         JE      @@5
  7725.         MOV     ECX,[EDX-skew].StrRec.refCnt
  7726.         INC     ECX
  7727.         JLE     @@5
  7728.         MOV     [EDX-skew].StrRec.refCnt,ECX
  7729. @@5:    MOV     [EAX].TVarData.VType,varString
  7730.         MOV     [EAX].TVarData.VString,EDX
  7731.         RET
  7732. @@6:    MOV     [EAX].TVarData.VType,varEmpty
  7733.         PUSH    EDX
  7734.         PUSH    EAX
  7735.         CALL    VariantCopyInd
  7736.         OR      EAX,EAX
  7737.         JNE     VarInvalidOp
  7738. @@7:
  7739. end;
  7740.  
  7741. procedure VarChangeType(var Dest: Variant; const Source: Variant;
  7742.   DestType: Word);
  7743. type
  7744.   TVarMem = array[0..3] of Integer;
  7745. var
  7746.   Temp: TVarData;
  7747. begin
  7748.   if TVarData(Dest).VType = varString then
  7749.   begin
  7750.     Temp.VType := varEmpty;
  7751.     if VariantChangeTypeEx(Variant(Temp), Source, $400, 0, DestType) <> 0 then
  7752.       VarCastError;
  7753.     VarClear(Dest);
  7754.     TVarMem(Dest)[0] := TVarMem(Temp)[0];
  7755.     TVarMem(Dest)[2] := TVarMem(Temp)[2];
  7756.     TVarMem(Dest)[3] := TVarMem(Temp)[3];
  7757.   end else
  7758.     if VariantChangeTypeEx(Dest, Source, $400, 0, DestType) <> 0 then
  7759.       VarCastError;
  7760. end;
  7761.  
  7762. procedure VarOleStrToString(var Dest: Variant; const Source: Variant);
  7763. var
  7764.   StringPtr: Pointer;
  7765. begin
  7766.   StringPtr := nil;
  7767.   OleStrToStrVar(TVarData(Source).VOleStr, string(StringPtr));
  7768.   VarClear(Dest);
  7769.   TVarData(Dest).VType := varString;
  7770.   TVarData(Dest).VString := StringPtr;
  7771. end;
  7772.  
  7773. procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
  7774. var
  7775.   OleStrPtr: PWideChar;
  7776. begin
  7777.   OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
  7778.   VarClear(Dest);
  7779.   TVarData(Dest).VType := varOleStr;
  7780.   TVarData(Dest).VOleStr := OleStrPtr;
  7781. end;
  7782.  
  7783. procedure VarCast(var Dest; const Source: Variant; VarType: Integer);
  7784. var
  7785.   SourceType, DestType: Word;
  7786.   Temp: TVarData;
  7787. begin
  7788.   SourceType := TVarData(Source).VType;
  7789.   DestType := Word(VarType);
  7790.   if SourceType = DestType then
  7791.     VarCopy(Dest, Source)
  7792.   else
  7793.   if SourceType = varString then
  7794.     if DestType = varOleStr then
  7795.       VarStringToOleStr(Variant(Dest), Source)
  7796.     else
  7797.     begin
  7798.       Temp.VType := varEmpty;
  7799.       VarStringToOleStr(Variant(Temp), Source);
  7800.       try
  7801.         VarChangeType(Variant(Dest), Variant(Temp), DestType);
  7802.       finally
  7803.         VarClear(Variant(Temp));
  7804.       end;
  7805.     end
  7806.   else
  7807.   if DestType = varString then
  7808.     if SourceType = varOleStr then
  7809.       VarOleStrToString(Variant(Dest), Source)
  7810.     else
  7811.     begin
  7812.       Temp.VType := varEmpty;
  7813.       VarChangeType(Variant(Temp), Source, varOleStr);
  7814.       try
  7815.         VarOleStrToString(Variant(Dest), Variant(Temp));
  7816.       finally
  7817.         VarClear(Variant(Temp));
  7818.       end;
  7819.     end
  7820.   else
  7821.     VarChangeType(Variant(Dest), Source, DestType);
  7822. end;
  7823.  
  7824. procedure _VarToInt;
  7825. asm
  7826.         XOR     EDX,EDX
  7827.         MOV     DX,[EAX].TVarData.VType
  7828.         CMP     EDX,varInteger
  7829.         JE      @@0
  7830.         CMP     EDX,varSmallint
  7831.         JE      @@1
  7832.         CMP     EDX,varByte
  7833.         JE      @@2
  7834.         CMP     EDX,varDouble
  7835.         JE      @@5
  7836.         CMP     EDX,varSingle
  7837.         JE      @@4
  7838.         CMP     EDX,varCurrency
  7839.         JE      @@3
  7840.         SUB     ESP,16
  7841.         MOV     [ESP].TVarData.VType,varEmpty
  7842.         MOV     EDX,EAX
  7843.         MOV     EAX,ESP
  7844.         MOV     ECX,varInteger
  7845.         CALL    VarCast
  7846.         MOV     EAX,[ESP].TVarData.VInteger
  7847.         ADD     ESP,16
  7848.         RET
  7849. @@0:    MOV     EAX,[EAX].TVarData.VInteger
  7850.         RET
  7851. @@1:    MOVSX   EAX,[EAX].TVarData.VSmallint
  7852.         RET
  7853. @@2:    MOVZX   EAX,[EAX].TVarData.VByte
  7854.         RET
  7855. @@3:    FILD    [EAX].TVarData.VCurrency
  7856.         FDIV    C10000
  7857.         JMP     @@6
  7858. @@4:    FLD     [EAX].TVarData.VSingle
  7859.         JMP     @@6
  7860. @@5:    FLD     [EAX].TVarData.VDouble
  7861. @@6:    PUSH    EAX
  7862.         FISTP   DWORD PTR [ESP]
  7863.         FWAIT
  7864.         POP     EAX
  7865. end;
  7866.  
  7867. procedure _VarToBool;
  7868. asm
  7869.         CMP     [EAX].TVarData.VType,varBoolean
  7870.         JE      @@1
  7871.         SUB     ESP,16
  7872.         MOV     [ESP].TVarData.VType,varEmpty
  7873.         MOV     EDX,EAX
  7874.         MOV     EAX,ESP
  7875.         MOV     ECX,varBoolean
  7876.         CALL    VarCast
  7877.         MOV     AX,[ESP].TVarData.VBoolean
  7878.         ADD     ESP,16
  7879.         JMP     @@2
  7880. @@1:    MOV     AX,[EAX].TVarData.VBoolean
  7881. @@2:    NEG     AX
  7882.         SBB     EAX,EAX
  7883.         NEG     EAX
  7884. end;
  7885.  
  7886. procedure _VarToReal;
  7887. asm
  7888.         XOR     EDX,EDX
  7889.         MOV     DX,[EAX].TVarData.VType
  7890.         CMP     EDX,varDouble
  7891.         JE      @@1
  7892.         CMP     EDX,varSingle
  7893.         JE      @@2
  7894.         CMP     EDX,varCurrency
  7895.         JE      @@3
  7896.         CMP     EDX,varInteger
  7897.         JE      @@4
  7898.         CMP     EDX,varSmallint
  7899.         JE      @@5
  7900.         CMP     EDX,varDate
  7901.         JE      @@1
  7902.         SUB     ESP,16
  7903.         MOV     [ESP].TVarData.VType,varEmpty
  7904.         MOV     EDX,EAX
  7905.         MOV     EAX,ESP
  7906.         MOV     ECX,varDouble
  7907.         CALL    VarCast
  7908.         FLD     [ESP].TVarData.VDouble
  7909.         ADD     ESP,16
  7910.         RET
  7911. @@1:    FLD     [EAX].TVarData.VDouble
  7912.         RET
  7913. @@2:    FLD     [EAX].TVarData.VSingle
  7914.         RET
  7915. @@3:    FILD    [EAX].TVarData.VCurrency
  7916.         FDIV    C10000
  7917.         RET
  7918. @@4:    FILD    [EAX].TVarData.VInteger
  7919.         RET
  7920. @@5:    FILD    [EAX].TVarData.VSmallint
  7921. end;
  7922.  
  7923. procedure _VarToCurr;
  7924. asm
  7925.         XOR     EDX,EDX
  7926.         MOV     DX,[EAX].TVarData.VType
  7927.         CMP     EDX,varCurrency
  7928.         JE      @@1
  7929.         CMP     EDX,varDouble
  7930.         JE      @@2
  7931.         CMP     EDX,varSingle
  7932.         JE      @@3
  7933.         CMP     EDX,varInteger
  7934.         JE      @@4
  7935.         CMP     EDX,varSmallint
  7936.         JE      @@5
  7937.         SUB     ESP,16
  7938.         MOV     [ESP].TVarData.VType,varEmpty
  7939.         MOV     EDX,EAX
  7940.         MOV     EAX,ESP
  7941.         MOV     ECX,varCurrency
  7942.         CALL    VarCast
  7943.         FILD    [ESP].TVarData.VCurrency
  7944.         ADD     ESP,16
  7945.         RET
  7946. @@1:    FILD    [EAX].TVarData.VCurrency
  7947.         RET
  7948. @@2:    FLD     [EAX].TVarData.VDouble
  7949.         JMP     @@6
  7950. @@3:    FLD     [EAX].TVarData.VSingle
  7951.         JMP     @@6
  7952. @@4:    FILD    [EAX].TVarData.VInteger
  7953.         JMP     @@6
  7954. @@5:    FILD    [EAX].TVarData.VSmallint
  7955. @@6:    FMUL    C10000
  7956. end;
  7957.  
  7958. procedure _VarToPStr(var S; const V: Variant);
  7959. var
  7960.   Temp: string;
  7961. begin
  7962.   _VarToLStr(Temp, V);
  7963.   ShortString(S) := Temp;
  7964. end;
  7965.  
  7966. procedure _VarToLStr(var S: string; const V: Variant);
  7967. asm
  7968.         CMP     [EDX].TVarData.VType,varString
  7969.         JNE     @@1
  7970.         MOV     EDX,[EDX].TVarData.VString
  7971.         JMP     _LStrAsg
  7972. @@1:    PUSH    EBX
  7973.         MOV     EBX,EAX
  7974.         SUB     ESP,16
  7975.         MOV     [ESP].TVarData.VType,varEmpty
  7976.         MOV     EAX,ESP
  7977.         MOV     ECX,varString
  7978.         CALL    VarCast
  7979.         MOV     EAX,EBX
  7980.         CALL    _LStrClr
  7981.         MOV     EAX,[ESP].TVarData.VString
  7982.         MOV     [EBX],EAX
  7983.         ADD     ESP,16
  7984.         POP     EBX
  7985. end;
  7986.  
  7987. procedure _VarToWStr(var S: WideString; const V: Variant);
  7988. asm
  7989.         CMP     [EDX].TVarData.VType,varOleStr
  7990.         JNE     @@1
  7991.         MOV     EDX,[EDX].TVarData.VOleStr
  7992.         JMP     _WStrAsg
  7993. @@1:    PUSH    EBX
  7994.         MOV     EBX,EAX
  7995.         SUB     ESP,16
  7996.         MOV     [ESP].TVarData.VType,varEmpty
  7997.         MOV     EAX,ESP
  7998.         MOV     ECX,varOleStr
  7999.         CALL    VarCast
  8000.         MOV     EAX,EBX
  8001.         MOV     EDX,[ESP].TVarData.VOleStr
  8002.         CALL    WStrSet
  8003.         ADD     ESP,16
  8004.         POP     EBX
  8005. end;
  8006.  
  8007. procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
  8008. asm
  8009.         CMP     [EDX].TVarData.VType,varEmpty
  8010.         JE      _IntfClear
  8011.         CMP     [EDX].TVarData.VType,varUnknown
  8012.         JE      @@2
  8013.         CMP     [EDX].TVarData.VType,varDispatch
  8014.         JE      @@2
  8015.         CMP     [EDX].TVarData.VType,varUnknown+varByRef
  8016.         JE      @@1
  8017.         CMP     [EDX].TVarData.VType,varDispatch+varByRef
  8018.         JNE     VarCastError
  8019. @@1:    MOV     EDX,[EDX].TVarData.VPointer
  8020.         MOV     EDX,[EDX]
  8021.         JMP     _IntfCopy
  8022. @@2:    MOV     EDX,[EDX].TVarData.VUnknown
  8023.         JMP     _IntfCopy
  8024. end;
  8025.  
  8026. procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
  8027. asm
  8028.         CMP     [EDX].TVarData.VType,varEmpty
  8029.         JE      _IntfClear
  8030.         CMP     [EDX].TVarData.VType,varDispatch
  8031.         JE      @@1
  8032.         CMP     [EDX].TVarData.VType,varDispatch+varByRef
  8033.         JNE     VarCastError
  8034.         MOV     EDX,[EDX].TVarData.VPointer
  8035.         MOV     EDX,[EDX]
  8036.         JMP     _IntfCopy
  8037. @@1:    MOV     EDX,[EDX].TVarData.VDispatch
  8038.         JMP     _IntfCopy
  8039. end;
  8040.  
  8041. procedure _VarFromInt;
  8042. asm
  8043.         CMP     [EAX].TVarData.VType,varOleStr
  8044.         JB      @@1
  8045.         PUSH    EAX
  8046.         PUSH    EDX
  8047.         CALL    VarClear
  8048.         POP     EDX
  8049.         POP     EAX
  8050. @@1:    MOV     [EAX].TVarData.VType,varInteger
  8051.         MOV     [EAX].TVarData.VInteger,EDX
  8052. end;
  8053.  
  8054. procedure _VarFromBool;
  8055. asm
  8056.         CMP     [EAX].TVarData.VType,varOleStr
  8057.         JB      @@1
  8058.         PUSH    EAX
  8059.         PUSH    EDX
  8060.         CALL    VarClear
  8061.         POP     EDX
  8062.         POP     EAX
  8063. @@1:    MOV     [EAX].TVarData.VType,varBoolean
  8064.         NEG     DL
  8065.         SBB     EDX,EDX
  8066.         MOV     [EAX].TVarData.VBoolean,DX
  8067. end;
  8068.  
  8069. procedure _VarFromReal;
  8070. asm
  8071.         CMP     [EAX].TVarData.VType,varOleStr
  8072.         JB      @@1
  8073.         PUSH    EAX
  8074.         CALL    VarClear
  8075.         POP     EAX
  8076. @@1:    MOV     [EAX].TVarData.VType,varDouble
  8077.         FSTP    [EAX].TVarData.VDouble
  8078.         FWAIT
  8079. end;
  8080.  
  8081. procedure _VarFromTDateTime;
  8082. asm
  8083.         CMP     [EAX].TVarData.VType,varOleStr
  8084.         JB      @@1
  8085.         PUSH    EAX
  8086.         CALL    VarClear
  8087.         POP     EAX
  8088. @@1:    MOV     [EAX].TVarData.VType,varDate
  8089.         FSTP    [EAX].TVarData.VDouble
  8090.         FWAIT
  8091. end;
  8092.  
  8093. procedure _VarFromCurr;
  8094. asm
  8095.         CMP     [EAX].TVarData.VType,varOleStr
  8096.         JB      @@1
  8097.         PUSH    EAX
  8098.         CALL    VarClear
  8099.         POP     EAX
  8100. @@1:    MOV     [EAX].TVarData.VType,varCurrency
  8101.         FISTP   [EAX].TVarData.VCurrency
  8102.         FWAIT
  8103. end;
  8104.  
  8105. procedure _VarFromPStr(var V: Variant; const Value: ShortString);
  8106. begin
  8107.   _VarFromLStr(V, Value);
  8108. end;
  8109.  
  8110. procedure _VarFromLStr(var V: Variant; const Value: string);
  8111. asm
  8112.         CMP     [EAX].TVarData.VType,varOleStr
  8113.         JB      @@1
  8114.         PUSH    EAX
  8115.         PUSH    EDX
  8116.         CALL    VarClear
  8117.         POP     EDX
  8118.         POP     EAX
  8119. @@1:    TEST    EDX,EDX
  8120.         JE      @@3
  8121.         MOV     ECX,[EDX-skew].StrRec.refCnt
  8122.         INC     ECX
  8123.         JLE     @@2
  8124.         MOV     [EDX-skew].StrRec.refCnt,ECX
  8125.         JMP     @@3
  8126. @@2:    PUSH    EAX
  8127.         PUSH    EDX
  8128.         MOV     EAX,[EDX-skew].StrRec.length
  8129.         CALL    _NewAnsiString
  8130.         MOV     EDX,EAX
  8131.         POP     EAX
  8132.         PUSH    EDX
  8133.         MOV     ECX,[EDX-skew].StrRec.length
  8134.         CALL    Move
  8135.         POP     EDX
  8136.         POP     EAX
  8137. @@3:    MOV     [EAX].TVarData.VType,varString
  8138.         MOV     [EAX].TVarData.VString,EDX
  8139. end;
  8140.  
  8141. procedure _VarFromWStr(var V: Variant; const Value: WideString);
  8142. asm
  8143.         PUSH    EAX
  8144.         CMP     [EAX].TVarData.VType,varOleStr
  8145.         JB      @@1
  8146.         PUSH    EDX
  8147.         CALL    VarClear
  8148.         POP     EDX
  8149. @@1:    XOR     EAX,EAX
  8150.         TEST    EDX,EDX
  8151.         JE      @@2
  8152.         MOV     EAX,[EDX-4]
  8153.         SHR     EAX,1
  8154.         JE      @@2
  8155.         PUSH    EAX
  8156.         PUSH    EDX
  8157.         CALL    SysAllocStringLen
  8158.         TEST    EAX,EAX
  8159.         JE      WStrError
  8160. @@2:    POP     EDX
  8161.         MOV     [EDX].TVarData.VType,varOleStr
  8162.         MOV     [EDX].TVarData.VOleStr,EAX
  8163. end;
  8164.  
  8165. procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
  8166. asm
  8167.         CMP     [EAX].TVarData.VType,varOleStr
  8168.         JB      @@1
  8169.         PUSH    EAX
  8170.         PUSH    EDX
  8171.         CALL    VarClear
  8172.         POP     EDX
  8173.         POP     EAX
  8174. @@1:    MOV     [EAX].TVarData.VType,varUnknown
  8175.         MOV     [EAX].TVarData.VUnknown,EDX
  8176.         TEST    EDX,EDX
  8177.         JE      @@2
  8178.         PUSH    EDX
  8179.         MOV     EAX,[EDX]
  8180.         CALL    [EAX].vmtAddRef.Pointer
  8181. @@2:
  8182. end;
  8183.  
  8184. procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
  8185. asm
  8186.         CMP     [EAX].TVarData.VType,varOleStr
  8187.         JB      @@1
  8188.         PUSH    EAX
  8189.         PUSH    EDX
  8190.         CALL    VarClear
  8191.         POP     EDX
  8192.         POP     EAX
  8193. @@1:    MOV     [EAX].TVarData.VType,varDispatch
  8194.         MOV     [EAX].TVarData.VDispatch,EDX
  8195.         TEST    EDX,EDX
  8196.         JE      @@2
  8197.         PUSH    EDX
  8198.         MOV     EAX,[EDX]
  8199.         CALL    [EAX].vmtAddRef.Pointer
  8200. @@2:
  8201. end;
  8202.  
  8203. procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
  8204. begin
  8205.   _OleVarFromLStr(V, Value);
  8206. end;
  8207.  
  8208.  
  8209. procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
  8210. asm
  8211.         CMP     [EAX].TVarData.VType,varOleStr
  8212.         JB      @@1
  8213.         PUSH    EAX
  8214.         PUSH    EDX
  8215.         CALL    VarClear
  8216.         POP     EDX
  8217.         POP     EAX
  8218. @@1:    MOV     [EAX].TVarData.VType,varOleStr
  8219.         ADD     EAX,TVarData.VOleStr
  8220.         XOR     ECX,ECX
  8221.         MOV     [EAX],ECX
  8222.         JMP     _WStrFromLStr
  8223. end;
  8224.  
  8225.  
  8226. procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
  8227. asm
  8228.         CMP     [EDX].TVarData.VType,varString
  8229.         JNE     _VarCopy
  8230.         CMP     [EAX].TVarData.VType,varOleStr
  8231.         JB      @@1
  8232.         PUSH    EAX
  8233.         PUSH    EDX
  8234.         CALL    VarClear
  8235.         POP     EDX
  8236.         POP     EAX
  8237. @@1:    MOV     [EAX].TVarData.VType,varOleStr
  8238.         ADD     EAX,TVarData.VOleStr
  8239.         ADD     EDX,TVarData.VString
  8240.         XOR     ECX,ECX
  8241.         MOV     [EAX],ECX
  8242.         JMP     _WStrFromLStr
  8243. end;
  8244.  
  8245.  
  8246. procedure VarStrCat(var Dest: Variant; const Source: Variant);
  8247. begin
  8248.   Dest := string(Dest) + string(Source);
  8249. end;
  8250.  
  8251. procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer);
  8252. asm
  8253.         PUSH    EBX
  8254.         PUSH    ESI
  8255.         PUSH    EDI
  8256.         MOV     EDI,EAX
  8257.         MOV     ESI,EDX
  8258.         MOV     EBX,ECX
  8259.         MOV     EAX,[EDI].TVarData.VType.Integer
  8260.         MOV     EDX,[ESI].TVarData.VType.Integer
  8261.         AND     EAX,varTypeMask
  8262.         AND     EDX,varTypeMask
  8263.         CMP     EAX,varLast
  8264.         JBE     @@1
  8265.         CMP     EAX,varString
  8266.         JNE     @InvalidOp
  8267.         MOV     EAX,varOleStr
  8268. @@1:    CMP     EDX,varLast
  8269.         JBE     @@2
  8270.         CMP     EDX,varString
  8271.         JNE     @InvalidOp
  8272.         MOV     EDX,varOleStr
  8273. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  8274.         MOV     DL,BaseTypeMap.Byte[EDX]
  8275.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  8276.         CALL    @VarOpTable.Pointer[ECX*4]
  8277.         POP     EDI
  8278.         POP     ESI
  8279.         POP     EBX
  8280.         RET
  8281.  
  8282. @VarOpTable:
  8283.         DD      @VarOpError
  8284.         DD      @VarOpNull
  8285.         DD      @VarOpInteger
  8286.         DD      @VarOpReal
  8287.         DD      @VarOpCurr
  8288.         DD      @VarOpString
  8289.         DD      @VarOpBoolean
  8290.         DD      @VarOpDate
  8291.  
  8292. @VarOpError:
  8293.         POP     EAX
  8294.  
  8295. @InvalidOp:
  8296.         POP     EDI
  8297.         POP     ESI
  8298.         POP     EBX
  8299.         JMP     VarInvalidOp
  8300.  
  8301. @VarOpNull:
  8302.         MOV     EAX,EDI
  8303.         CALL    VarClear
  8304.         MOV     [EDI].TVarData.VType,varNull
  8305.         RET
  8306.  
  8307. @VarOpInteger:
  8308.         CMP     BL,opDvd
  8309.         JE      @RealOp
  8310.  
  8311. @IntegerOp:
  8312.         MOV     EAX,ESI
  8313.         CALL    _VarToInt
  8314.         PUSH    EAX
  8315.         MOV     EAX,EDI
  8316.         CALL    _VarToInt
  8317.         POP     EDX
  8318.         CALL    @IntegerOpTable.Pointer[EBX*4]
  8319.         MOV     EDX,EAX
  8320.         MOV     EAX,EDI
  8321.         JMP     _VarFromInt
  8322.  
  8323. @IntegerOpTable:
  8324.         DD      @IntegerAdd
  8325.         DD      @IntegerSub
  8326.         DD      @IntegerMul
  8327.         DD      0
  8328.         DD      @IntegerDiv
  8329.         DD      @IntegerMod
  8330.         DD      @IntegerShl
  8331.         DD      @IntegerShr
  8332.         DD      @IntegerAnd
  8333.         DD      @IntegerOr
  8334.         DD      @IntegerXor
  8335.  
  8336. @IntegerAdd:
  8337.         ADD     EAX,EDX
  8338.         JO      @IntToRealOp
  8339.         RET
  8340.  
  8341. @IntegerSub:
  8342.         SUB     EAX,EDX
  8343.         JO      @IntToRealOp
  8344.         RET
  8345.  
  8346. @IntegerMul:
  8347.         IMUL    EDX
  8348.         JO      @IntToRealOp
  8349.         RET
  8350.  
  8351. @IntegerDiv:
  8352.         MOV     ECX,EDX
  8353.         CDQ
  8354.         IDIV    ECX
  8355.         RET
  8356.  
  8357. @IntegerMod:
  8358.         MOV     ECX,EDX
  8359.         CDQ
  8360.         IDIV    ECX
  8361.         MOV     EAX,EDX
  8362.         RET
  8363.  
  8364. @IntegerShl:
  8365.         MOV     ECX,EDX
  8366.         SHL     EAX,CL
  8367.         RET
  8368.  
  8369. @IntegerShr:
  8370.         MOV     ECX,EDX
  8371.         SHR     EAX,CL
  8372.         RET
  8373.  
  8374. @IntegerAnd:
  8375.         AND     EAX,EDX
  8376.         RET
  8377.  
  8378. @IntegerOr:
  8379.         OR      EAX,EDX
  8380.         RET
  8381.  
  8382. @IntegerXor:
  8383.         XOR     EAX,EDX
  8384.         RET
  8385.  
  8386. @IntToRealOp:
  8387.         POP     EAX
  8388.         JMP     @RealOp
  8389.  
  8390. @VarOpReal:
  8391.         CMP     BL,opDiv
  8392.         JAE     @IntegerOp
  8393.  
  8394. @RealOp:
  8395.         MOV     EAX,ESI
  8396.         CALL    _VarToReal
  8397.         SUB     ESP,12
  8398.         FSTP    TBYTE PTR [ESP]
  8399.         MOV     EAX,EDI
  8400.         CALL    _VarToReal
  8401.         FLD     TBYTE PTR [ESP]
  8402.         ADD     ESP,12
  8403.         CALL    @RealOpTable.Pointer[EBX*4]
  8404.  
  8405. @RealResult:
  8406.         MOV     EAX,EDI
  8407.         JMP     _VarFromReal
  8408.  
  8409. @VarOpCurr:
  8410.         CMP     BL,opDiv
  8411.         JAE     @IntegerOp
  8412.         CMP     BL,opMul
  8413.         JAE     @CurrMulDvd
  8414.         MOV     EAX,ESI
  8415.         CALL    _VarToCurr
  8416.         SUB     ESP,12
  8417.         FSTP    TBYTE PTR [ESP]
  8418.         MOV     EAX,EDI
  8419.         CALL    _VarToCurr
  8420.         FLD     TBYTE PTR [ESP]
  8421.         ADD     ESP,12
  8422.         CALL    @RealOpTable.Pointer[EBX*4]
  8423.  
  8424. @CurrResult:
  8425.         MOV     EAX,EDI
  8426.         JMP     _VarFromCurr
  8427.  
  8428. @CurrMulDvd:
  8429.         CMP     DL,btCur
  8430.         JE      @CurrOpCurr
  8431.         MOV     EAX,ESI
  8432.         CALL    _VarToReal
  8433.         FILD    [EDI].TVarData.VCurrency
  8434.         FXCH
  8435.         CALL    @RealOpTable.Pointer[EBX*4]
  8436.         JMP     @CurrResult
  8437.  
  8438. @CurrOpCurr:
  8439.         CMP     BL,opDvd
  8440.         JE      @CurrDvdCurr
  8441.         CMP     AL,btCur
  8442.         JE      @CurrMulCurr
  8443.         MOV     EAX,EDI
  8444.         CALL    _VarToReal
  8445.         FILD    [ESI].TVarData.VCurrency
  8446.         FMUL
  8447.         JMP     @CurrResult
  8448.  
  8449. @CurrMulCurr:
  8450.         FILD    [EDI].TVarData.VCurrency
  8451.         FILD    [ESI].TVarData.VCurrency
  8452.         FMUL
  8453.         FDIV    C10000
  8454.         JMP     @CurrResult
  8455.  
  8456. @CurrDvdCurr:
  8457.         MOV     EAX,EDI
  8458.         CALL    _VarToCurr
  8459.         FILD    [ESI].TVarData.VCurrency
  8460.         FDIV
  8461.         JMP     @RealResult
  8462.  
  8463. @RealOpTable:
  8464.         DD      @RealAdd
  8465.         DD      @RealSub
  8466.         DD      @RealMul
  8467.         DD      @RealDvd
  8468.  
  8469. @RealAdd:
  8470.         FADD
  8471.         RET
  8472.  
  8473. @RealSub:
  8474.         FSUB
  8475.         RET
  8476.  
  8477. @RealMul:
  8478.         FMUL
  8479.         RET
  8480.  
  8481. @RealDvd:
  8482.         FDIV
  8483.         RET
  8484.  
  8485. @VarOpString:
  8486.         CMP     BL,opAdd
  8487.         JNE     @VarOpReal
  8488.         MOV     EAX,EDI
  8489.         MOV     EDX,ESI
  8490.         JMP     VarStrCat
  8491.  
  8492. @VarOpBoolean:
  8493.         CMP     BL,opAnd
  8494.         JB      @VarOpReal
  8495.         MOV     EAX,ESI
  8496.         CALL    _VarToBool
  8497.         PUSH    EAX
  8498.         MOV     EAX,EDI
  8499.         CALL    _VarToBool
  8500.         POP     EDX
  8501.         CALL    @IntegerOpTable.Pointer[EBX*4]
  8502.         MOV     EDX,EAX
  8503.         MOV     EAX,EDI
  8504.         JMP     _VarFromBool
  8505.  
  8506. @VarOpDate:
  8507.         CMP     BL,opSub
  8508.         JA      @VarOpReal
  8509.         JB      @DateOp
  8510.         MOV     AH,DL
  8511.         CMP     AX,btDat+btDat*256
  8512.         JE      @RealOp
  8513.  
  8514. @DateOp:
  8515.         CALL    @RealOp
  8516.         MOV     [EDI].TVarData.VType,varDate
  8517.         RET
  8518. end;
  8519.  
  8520. procedure _VarAdd;
  8521. asm
  8522.         MOV     ECX,opAdd
  8523.         JMP     VarOp
  8524. end;
  8525.  
  8526. procedure _VarSub;
  8527. asm
  8528.         MOV     ECX,opSub
  8529.         JMP     VarOp
  8530. end;
  8531.  
  8532. procedure _VarMul;
  8533. asm
  8534.         MOV     ECX,opMul
  8535.         JMP     VarOp
  8536. end;
  8537.  
  8538. procedure _VarDiv;
  8539. asm
  8540.         MOV     ECX,opDiv
  8541.         JMP     VarOp
  8542. end;
  8543.  
  8544. procedure _VarMod;
  8545. asm
  8546.         MOV     ECX,opMod
  8547.         JMP     VarOp
  8548. end;
  8549.  
  8550. procedure _VarAnd;
  8551. asm
  8552.         MOV     ECX,opAnd
  8553.         JMP     VarOp
  8554. end;
  8555.  
  8556. procedure _VarOr;
  8557. asm
  8558.         MOV     ECX,opOr
  8559.         JMP     VarOp
  8560. end;
  8561.  
  8562. procedure _VarXor;
  8563. asm
  8564.         MOV     ECX,opXor
  8565.         JMP     VarOp
  8566. end;
  8567.  
  8568. procedure _VarShl;
  8569. asm
  8570.         MOV     ECX,opShl
  8571.         JMP     VarOp
  8572. end;
  8573.  
  8574. procedure _VarShr;
  8575. asm
  8576.         MOV     ECX,opShr
  8577.         JMP     VarOp
  8578. end;
  8579.  
  8580. procedure _VarRDiv;
  8581. asm
  8582.         MOV     ECX,opDvd
  8583.         JMP     VarOp
  8584. end;
  8585.  
  8586. function VarCompareString(const S1, S2: string): Integer;
  8587. asm
  8588.         PUSH    ESI
  8589.         PUSH    EDI
  8590.         MOV     ESI,EAX
  8591.         MOV     EDI,EDX
  8592.         OR      EAX,EAX
  8593.         JE      @@1
  8594.         MOV     EAX,[EAX-4]
  8595. @@1:    OR      EDX,EDX
  8596.         JE      @@2
  8597.         MOV     EDX,[EDX-4]
  8598. @@2:    MOV     ECX,EAX
  8599.         CMP     ECX,EDX
  8600.         JBE     @@3
  8601.         MOV     ECX,EDX
  8602. @@3:    CMP     ECX,ECX
  8603.         REPE    CMPSB
  8604.         JE      @@4
  8605.         MOVZX   EAX,BYTE PTR [ESI-1]
  8606.         MOVZX   EDX,BYTE PTR [EDI-1]
  8607. @@4:    SUB     EAX,EDX
  8608.         POP     EDI
  8609.         POP     ESI
  8610. end;
  8611.  
  8612. function VarCmpStr(const V1, V2: Variant): Integer;
  8613. begin
  8614.   Result := VarCompareString(V1, V2);
  8615. end;
  8616.  
  8617. procedure _VarCmp;
  8618. asm
  8619.         PUSH    ESI
  8620.         PUSH    EDI
  8621.         MOV     EDI,EAX
  8622.         MOV     ESI,EDX
  8623.         MOV     EAX,[EDI].TVarData.VType.Integer
  8624.         MOV     EDX,[ESI].TVarData.VType.Integer
  8625.         AND     EAX,varTypeMask
  8626.         AND     EDX,varTypeMask
  8627.         CMP     EAX,varLast
  8628.         JBE     @@1
  8629.         CMP     EAX,varString
  8630.         JNE     @VarCmpError
  8631.         MOV     EAX,varOleStr
  8632. @@1:    CMP     EDX,varLast
  8633.         JBE     @@2
  8634.         CMP     EDX,varString
  8635.         JNE     @VarCmpError
  8636.         MOV     EDX,varOleStr
  8637. @@2:    MOV     AL,BaseTypeMap.Byte[EAX]
  8638.         MOV     DL,BaseTypeMap.Byte[EDX]
  8639.         MOVZX   ECX,OpTypeMap.Byte[EAX*8+EDX]
  8640.         JMP     @VarCmpTable.Pointer[ECX*4]
  8641.  
  8642. @VarCmpTable:
  8643.         DD      @VarCmpError
  8644.         DD      @VarCmpNull
  8645.         DD      @VarCmpInteger
  8646.         DD      @VarCmpReal
  8647.         DD      @VarCmpCurr
  8648.         DD      @VarCmpString
  8649.         DD      @VarCmpBoolean
  8650.         DD      @VarCmpDate
  8651.  
  8652. @VarCmpError:
  8653.         POP     EDI
  8654.         POP     ESI
  8655.         JMP     VarInvalidOp
  8656.  
  8657. @VarCmpNull:
  8658.         CMP     AL,DL
  8659.         JMP     @Exit
  8660.  
  8661. @VarCmpInteger:
  8662.         MOV     EAX,ESI
  8663.         CALL    _VarToInt
  8664.         XCHG    EAX,EDI
  8665.         CALL    _VarToInt
  8666.         CMP     EAX,EDI
  8667.         JMP     @Exit
  8668.  
  8669. @VarCmpReal:
  8670. @VarCmpDate:
  8671.         MOV     EAX,EDI
  8672.         CALL    _VarToReal
  8673.         SUB     ESP,12
  8674.         FSTP    TBYTE PTR [ESP]
  8675.         MOV     EAX,ESI
  8676.         CALL    _VarToReal
  8677.         FLD     TBYTE PTR [ESP]
  8678.         ADD     ESP,12
  8679.  
  8680. @RealCmp:
  8681.         FCOMPP
  8682.         FNSTSW  AX
  8683.         MOV     AL,AH   { Move CF into SF }
  8684.         AND     AX,4001H
  8685.         ROR     AL,1
  8686.         OR      AH,AL
  8687.         SAHF
  8688.         JMP     @Exit
  8689.  
  8690. @VarCmpCurr:
  8691.         MOV     EAX,EDI
  8692.         CALL    _VarToCurr
  8693.         SUB     ESP,12
  8694.         FSTP    TBYTE PTR [ESP]
  8695.         MOV     EAX,ESI
  8696.         CALL    _VarToCurr
  8697.         FLD     TBYTE PTR [ESP]
  8698.         ADD     ESP,12
  8699.         JMP     @RealCmp
  8700.  
  8701. @VarCmpString:
  8702.         MOV     EAX,EDI
  8703.         MOV     EDX,ESI
  8704.         CALL    VarCmpStr
  8705.         CMP     EAX,0
  8706.         JMP     @Exit
  8707.  
  8708. @VarCmpBoolean:
  8709.         MOV     EAX,ESI
  8710.         CALL    _VarToBool
  8711.         XCHG    EAX,EDI
  8712.         CALL    _VarToBool
  8713.         MOV     EDX,EDI
  8714.         CMP     AL,DL
  8715.  
  8716. @Exit:
  8717.         POP     EDI
  8718.         POP     ESI
  8719. end;
  8720.  
  8721. procedure _VarNeg;
  8722. asm
  8723.         MOV     EDX,[EAX].TVarData.VType.Integer
  8724.         AND     EDX,varTypeMask
  8725.         CMP     EDX,varLast
  8726.         JBE     @@1
  8727.         CMP     EDX,varString
  8728.         JNE     @VarNegError
  8729.         MOV     EDX,varOleStr
  8730. @@1:    MOV     DL,BaseTypeMap.Byte[EDX]
  8731.         JMP     @VarNegTable.Pointer[EDX*4]
  8732.  
  8733. @VarNegTable:
  8734.         DD      @VarNegError
  8735.         DD      @VarNegNull
  8736.         DD      @VarNegInteger
  8737.         DD      @VarNegReal
  8738.         DD      @VarNegCurr
  8739.         DD      @VarNegReal
  8740.         DD      @VarNegInteger
  8741.         DD      @VarNegDate
  8742.  
  8743. @VarNegError:
  8744.         JMP     VarInvalidOp
  8745.  
  8746. @VarNegNull:
  8747.         RET
  8748.  
  8749. @VarNegInteger:
  8750.         PUSH    EAX
  8751.         CALL    _VarToInt
  8752.         NEG     EAX
  8753.         MOV     EDX,EAX
  8754.         POP     EAX
  8755.         JMP     _VarFromInt
  8756.  
  8757. @VarNegReal:
  8758.         PUSH    EAX
  8759.         CALL    _VarToReal
  8760.         FCHS
  8761.         POP     EAX
  8762.         JMP     _VarFromReal
  8763.  
  8764. @VarNegCurr:
  8765.         FILD    [EAX].TVarData.VCurrency
  8766.         FCHS
  8767.         FISTP   [EAX].TVarData.VCurrency
  8768.         FWAIT
  8769.         RET
  8770.  
  8771. @VarNegDate:
  8772.         FLD     [EAX].TVarData.VDate
  8773.         FCHS
  8774.         FSTP    [EAX].TVarData.VDate
  8775.         FWAIT
  8776. end;
  8777.  
  8778. procedure _VarNot;
  8779. asm
  8780.         MOV     EDX,[EAX].TVarData.VType.Integer
  8781.         AND     EDX,varTypeMask
  8782.         JE      @@2
  8783.         CMP     EDX,varBoolean
  8784.         JE      @@3
  8785.         CMP     EDX,varNull
  8786.         JE      @@4
  8787.         CMP     EDX,varLast
  8788.         JBE     @@1
  8789.         CMP     EDX,varString
  8790.         JNE     @@2
  8791. @@1:    PUSH    EAX
  8792.         CALL    _VarToInt
  8793.         NOT     EAX
  8794.         MOV     EDX,EAX
  8795.         POP     EAX
  8796.         JMP     _VarFromInt
  8797. @@2:    JMP     VarInvalidOp
  8798. @@3:    MOV     DX,[EAX].TVarData.VBoolean
  8799.         NEG     DX
  8800.         SBB     EDX,EDX
  8801.         NOT     EDX
  8802.         MOV     [EAX].TVarData.VBoolean,DX
  8803. @@4:
  8804. end;
  8805.  
  8806. procedure _VarCopy;
  8807. asm
  8808.         JMP     VarCopy
  8809. end;
  8810.  
  8811. procedure _VarClr;
  8812. asm
  8813.         PUSH    EAX
  8814.         CALL    VarClear
  8815.         POP     EAX
  8816. end;
  8817.  
  8818. procedure _VarAddRef;
  8819. asm
  8820.         CMP     [EAX].TVarData.VType,varOleStr
  8821.         JB      @@1
  8822.         PUSH    [EAX].Integer[12]
  8823.         PUSH    [EAX].Integer[8]
  8824.         PUSH    [EAX].Integer[4]
  8825.         PUSH    [EAX].Integer[0]
  8826.         MOV     [EAX].TVarData.VType,varEmpty
  8827.         MOV     EDX,ESP
  8828.         CALL    VarCopy
  8829.         ADD     ESP,16
  8830. @@1:
  8831. end;
  8832.  
  8833. function VarType(const V: Variant): Integer;
  8834. asm
  8835.         MOVZX   EAX,[EAX].TVarData.VType
  8836. end;
  8837.  
  8838. function VarAsType(const V: Variant; VarType: Integer): Variant;
  8839. begin
  8840.   VarCast(Result, V, VarType);
  8841. end;
  8842.  
  8843. function VarIsEmpty(const V: Variant): Boolean;
  8844. begin
  8845.   with TVarData(V) do
  8846.     Result := (VType = varEmpty) or ((VType = varDispatch) or
  8847.       (VType = varUnknown)) and (VDispatch = nil);
  8848. end;
  8849.  
  8850. function VarIsNull(const V: Variant): Boolean;
  8851. begin
  8852.   Result := TVarData(V).VType = varNull;
  8853. end;
  8854.  
  8855. function VarToStr(const V: Variant): string;
  8856. begin
  8857.   if TVarData(V).VType <> varNull then Result := V else Result := '';
  8858. end;
  8859.  
  8860. function VarFromDateTime(DateTime: TDateTime): Variant;
  8861. begin
  8862.   VarClear(Result);
  8863.   TVarData(Result).VType := varDate;
  8864.   TVarData(Result).VDate := DateTime;
  8865. end;
  8866.  
  8867. function VarToDateTime(const V: Variant): TDateTime;
  8868. var
  8869.   Temp: TVarData;
  8870. begin
  8871.   Temp.VType := varEmpty;
  8872.   VarCast(Variant(Temp), V, varDate);
  8873.   Result := Temp.VDate;
  8874. end;
  8875.  
  8876. function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
  8877. var
  8878.   S: string;
  8879. begin
  8880.   if TVarData(V).VType >= varSmallint then S := V;
  8881.   Write(T, S: Width);
  8882.   Result := @T;
  8883. end;
  8884.  
  8885. function _Write0Variant(var T: Text; const V: Variant): Pointer;
  8886. begin
  8887.   Result := _WriteVariant(T, V, 0);
  8888. end;
  8889.  
  8890. { ----------------------------------------------------- }
  8891. {       Variant array support                           }
  8892. { ----------------------------------------------------- }
  8893.  
  8894. function VarArrayCreate(const Bounds: array of Integer;
  8895.   VarType: Integer): Variant;
  8896. var
  8897.   I, DimCount: Integer;
  8898.   VarArrayRef: PVarArray;
  8899.   VarBounds: array[0..63] of TVarArrayBound;
  8900. begin
  8901.   if not Odd(High(Bounds)) or (High(Bounds) > 127) then
  8902.     Error(reVarArrayCreate);
  8903.   DimCount := (High(Bounds) + 1) div 2;
  8904.   for I := 0 to DimCount - 1 do
  8905.     with VarBounds[I] do
  8906.     begin
  8907.       LowBound := Bounds[I * 2];
  8908.       ElementCount := Bounds[I * 2 + 1] - LowBound + 1;
  8909.     end;
  8910.   VarArrayRef := SafeArrayCreate(VarType, DimCount, VarBounds);
  8911.   if VarArrayRef = nil then Error(reVarArrayCreate);
  8912.   VarClear(Result);
  8913.   TVarData(Result).VType := VarType or varArray;
  8914.   TVarData(Result).VArray := VarArrayRef;
  8915. end;
  8916.  
  8917. function VarArrayOf(const Values: array of Variant): Variant;
  8918. var
  8919.   I: Integer;
  8920. begin
  8921.   Result := VarArrayCreate([0, High(Values)], varVariant);
  8922.   for I := 0 to High(Values) do Result[I] := Values[I];
  8923. end;
  8924.  
  8925. procedure VarArrayRedim(var A; HighBound: Integer);
  8926. var
  8927.   VarBound: TVarArrayBound;
  8928. begin
  8929.   if (TVarData(A).VType and (varArray or varByRef)) <> varArray then
  8930.     Error(reVarNotArray);
  8931.   with TVarData(A).VArray^ do
  8932.     VarBound.LowBound := Bounds[DimCount - 1].LowBound;
  8933.   VarBound.ElementCount := HighBound - VarBound.LowBound + 1;
  8934.   if SafeArrayRedim(TVarData(A).VArray, VarBound) <> 0 then
  8935.     Error(reVarArrayCreate);
  8936. end;
  8937.  
  8938. function GetVarArray(const A: Variant): PVarArray;
  8939. begin
  8940.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  8941.   if TVarData(A).VType and varByRef <> 0 then
  8942.     Result := PVarArray(TVarData(A).VPointer^) else
  8943.     Result := TVarData(A).VArray;
  8944. end;
  8945.  
  8946. function VarArrayDimCount(const A: Variant): Integer;
  8947. begin
  8948.   if TVarData(A).VType and varArray <> 0 then
  8949.     Result := GetVarArray(A)^.DimCount else
  8950.     Result := 0;
  8951. end;
  8952.  
  8953. function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
  8954. begin
  8955.   if SafeArrayGetLBound(GetVarArray(A), Dim, Result) <> 0 then
  8956.     Error(reVarArrayBounds);
  8957. end;
  8958.  
  8959. function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
  8960. begin
  8961.   if SafeArrayGetUBound(GetVarArray(A), Dim, Result) <> 0 then
  8962.     Error(reVarArrayBounds);
  8963. end;
  8964.  
  8965. function VarArrayLock(const A: Variant): Pointer;
  8966. begin
  8967.   if SafeArrayAccessData(GetVarArray(A), Result) <> 0 then
  8968.     Error(reVarNotArray);
  8969. end;
  8970.  
  8971. procedure VarArrayUnlock(const A: Variant);
  8972. begin
  8973.   if SafeArrayUnaccessData(GetVarArray(A)) <> 0 then
  8974.     Error(reVarNotArray);
  8975. end;
  8976.  
  8977. function VarArrayRef(const A: Variant): Variant;
  8978. begin
  8979.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  8980.   VarClear(Result);
  8981.   TVarData(Result).VType := TVarData(A).VType or varByRef;
  8982.   if TVarData(A).VType and varByRef <> 0 then
  8983.     TVarData(Result).VPointer := TVarData(A).VPointer else
  8984.     TVarData(Result).VPointer := @TVarData(A).VArray;
  8985. end;
  8986.  
  8987. function VarIsArray(const A: Variant): Boolean;
  8988. begin
  8989.   Result := TVarData(A).VType and varArray <> 0;
  8990. end;
  8991.  
  8992. function _VarArrayGet(var A: Variant; IndexCount: Integer;
  8993.   Indices: Integer): Variant; cdecl;
  8994. var
  8995.   VarArrayPtr: PVarArray;
  8996.   VarType: Integer;
  8997. begin
  8998.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  8999.   VarArrayPtr := GetVarArray(A);
  9000.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  9001.   VarType := TVarData(A).VType and varTypeMask;
  9002.   VarClear(Result);
  9003.   if VarType = varVariant then
  9004.   begin
  9005.     if SafeArrayGetElement(VarArrayPtr, @Indices, @Result) <> 0 then
  9006.       Error(reVarArrayBounds);
  9007.   end else
  9008.   begin
  9009.     if SafeArrayGetElement(VarArrayPtr, @Indices,
  9010.       @TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds);
  9011.     TVarData(Result).VType := VarType;
  9012.   end;
  9013. end;
  9014.  
  9015. procedure _VarArrayPut(var A: Variant; const Value: Variant;
  9016.   IndexCount: Integer; Indices: Integer); cdecl;
  9017. var
  9018.   VarArrayPtr: PVarArray;
  9019.   VarType: Integer;
  9020.   P: Pointer;
  9021.   Temp: TVarData;
  9022. begin
  9023.   if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  9024.   VarArrayPtr := GetVarArray(A);
  9025.   if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  9026.   VarType := TVarData(A).VType and varTypeMask;
  9027.   if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
  9028.   begin
  9029.     if SafeArrayPutElement(VarArrayPtr, @Indices, @Value) <> 0 then
  9030.       Error(reVarArrayBounds);
  9031.   end else
  9032.   begin
  9033.     Temp.VType := varEmpty;
  9034.     try
  9035.       if VarType = varVariant then
  9036.       begin
  9037.         VarStringToOleStr(Variant(Temp), Value);
  9038.         P := @Temp;
  9039.       end else
  9040.       begin
  9041.         VarCast(Variant(Temp), Value, VarType);
  9042.         case VarType of
  9043.           varOleStr, varDispatch, varUnknown:
  9044.             P := Temp.VPointer;
  9045.         else
  9046.           P := @Temp.VPointer;
  9047.         end;
  9048.       end;
  9049.       if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
  9050.         Error(reVarArrayBounds);
  9051.     finally
  9052.       VarClear(Variant(Temp));
  9053.     end;
  9054.   end;
  9055. end;
  9056.  
  9057. { Package/Module registration/unregistration }
  9058.  
  9059. function FindHInstance(Address: Pointer): Longint;
  9060. var
  9061.   MemInfo: TMemInfo;
  9062. begin
  9063.   VirtualQuery(Address, MemInfo, SizeOf(MemInfo));
  9064.   if MemInfo.State = $1000{MEM_COMMIT} then
  9065.     Result := Longint(MemInfo.AllocationBase)
  9066.   else Result := 0;
  9067. end;
  9068.  
  9069. function FindClassHInstance(ClassType: TClass): Longint;
  9070. begin
  9071.   Result := FindHInstance(Pointer(ClassType));
  9072. end;
  9073.  
  9074. function FindResourceHInstance(Instance: Longint): Longint;
  9075. var
  9076.   CurModule: PLibModule;
  9077. begin
  9078.   CurModule := LibModuleList;
  9079.   while CurModule <> nil do
  9080.   begin
  9081.     if Instance = CurModule.Instance then
  9082.     begin
  9083.       Result := CurModule.ResInstance;
  9084.       Exit;
  9085.     end;
  9086.     CurModule := CurModule.Next;
  9087.   end;
  9088.   Result := Instance;
  9089. end;
  9090.  
  9091. procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer);
  9092. var
  9093.   CurModule: PLibModule;
  9094. begin
  9095.   CurModule := LibModuleList;
  9096.   while CurModule <> nil do
  9097.   begin
  9098.     if not Func(CurModule.Instance, Data) then Exit;
  9099.     CurModule := CurModule.Next;
  9100.   end;
  9101. end;
  9102.  
  9103. procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
  9104. var
  9105.   CurModule: PLibModule;
  9106. begin
  9107.   CurModule := LibModuleList;
  9108.   while CurModule <> nil do
  9109.   begin
  9110.     if not Func(CurModule.ResInstance, Data) then Exit;
  9111.     CurModule := CurModule.Next;
  9112.   end;
  9113. end;
  9114.  
  9115. procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
  9116. var
  9117.   P: PModuleUnloadRec;
  9118. begin
  9119.   New(P);
  9120.   P.Next := ModuleUnloadList;
  9121.   @P.Proc := @Proc;
  9122.   ModuleUnloadList := P;
  9123. end;
  9124.  
  9125. procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
  9126. var
  9127.   P, C: PModuleUnloadRec;
  9128. begin
  9129.   P := ModuleUnloadList;
  9130.   if (P <> nil) and (@P.Proc = @Proc) then
  9131.   begin
  9132.     ModuleUnloadList := ModuleUnloadList.Next;
  9133.     Dispose(P);
  9134.   end else
  9135.   begin
  9136.     C := P;
  9137.     while C <> nil do
  9138.     begin
  9139.       if (C.Next <> nil) and (@C.Next.Proc = @Proc) then
  9140.       begin
  9141.         P := C.Next;
  9142.         C.Next := C.Next.Next;
  9143.         Dispose(P);
  9144.         Break;
  9145.       end;
  9146.       C := C.Next;
  9147.     end;
  9148.   end;
  9149. end;
  9150.  
  9151. procedure NotifyModuleUnload(HInstance: Longint);
  9152. var
  9153.   P: PModuleUnloadRec;
  9154. begin
  9155.   P := ModuleUnloadList;
  9156.   while P <> nil do
  9157.   begin
  9158.     try
  9159.       P.Proc(HInstance);
  9160.     except
  9161.       // Make sure it doesn't stop notifications
  9162.     end;
  9163.     P := P.Next;
  9164.   end;
  9165. end;
  9166.  
  9167. procedure RegisterModule(LibModule: PLibModule);
  9168. begin
  9169.   LibModule.Next := LibModuleList;
  9170.   LibModuleList := LibModule;
  9171. end;
  9172.  
  9173. procedure UnregisterModule(LibModule: PLibModule);
  9174. var
  9175.   CurModule: PLibModule;
  9176. begin
  9177.   try
  9178.     NotifyModuleUnload(LibModule.Instance);
  9179.   finally
  9180.     if LibModule = LibModuleList then
  9181.       LibModuleList := LibModule.Next
  9182.     else
  9183.     begin
  9184.       CurModule := LibModuleList;
  9185.       while CurModule <> nil do
  9186.       begin
  9187.         if CurModule.Next = LibModule then
  9188.         begin
  9189.           CurModule.Next := LibModule.Next;
  9190.           Break;
  9191.         end;
  9192.         CurModule := CurModule.Next;
  9193.       end;
  9194.     end;
  9195.   end;
  9196. end;
  9197.  
  9198. { ResString support function }
  9199.  
  9200. function LoadResString(ResStringRec: PResStringRec): string;
  9201. var
  9202.   Buffer: array[0..1023] of Char;
  9203. begin
  9204.   SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^),
  9205.     ResStringRec.Identifier, Buffer, SizeOf(Buffer)));
  9206. end;
  9207.  
  9208. procedure _IntfClear(var Dest: IUnknown);
  9209. asm
  9210.         MOV     EDX,[EAX]
  9211.         TEST    EDX,EDX
  9212.         JE      @@1
  9213.         MOV     DWORD PTR [EAX],0
  9214.         PUSH    EAX
  9215.         PUSH    EDX
  9216.         MOV     EAX,[EDX]
  9217.         CALL    [EAX].vmtRelease.Pointer
  9218.         POP     EAX
  9219. @@1:
  9220. end;
  9221.  
  9222. procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
  9223. asm
  9224.         MOV     ECX,[EAX]       { save dest }
  9225.         MOV     [EAX],EDX       { assign dest }
  9226.         TEST    EDX,EDX         { need to addref source before releasing dest }
  9227.         JE      @@1             { to make self assignment (I := I) work right }
  9228.         PUSH    ECX
  9229.         PUSH    EDX
  9230.         MOV     EAX,[EDX]
  9231.         CALL    [EAX].vmtAddRef.Pointer
  9232.         POP     ECX
  9233. @@1:    TEST    ECX,ECX
  9234.         JE      @@2
  9235.         PUSH    ECX
  9236.         MOV     EAX,[ECX]
  9237.         CALL    [EAX].vmtRelease.Pointer
  9238. @@2:
  9239. end;
  9240.  
  9241. procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
  9242. asm
  9243.         TEST    EDX,EDX
  9244.         JE      _IntfClear
  9245.         PUSH    EAX
  9246.         PUSH    ECX
  9247.         PUSH    EDX
  9248.         MOV     ECX,[EAX]
  9249.         TEST    ECX,ECX
  9250.         JE      @@1
  9251.         PUSH    ECX
  9252.         MOV     EAX,[ECX]
  9253.         CALL    [EAX].vmtRelease.Pointer
  9254.         MOV     EDX,[ESP]
  9255. @@1:    MOV     EAX,[EDX]
  9256.         CALL    [EAX].vmtQueryInterface.Pointer
  9257.         TEST    EAX,EAX
  9258.         JE      @@2
  9259.         MOV     AL,reIntfCastError
  9260.         JMP     Error
  9261. @@2:
  9262. end;
  9263.  
  9264. procedure _IntfAddRef(const Dest: IUnknown);
  9265. begin
  9266.   if Dest <> nil then Dest._AddRef;
  9267. end;
  9268.  
  9269. function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): Integer;
  9270. const
  9271.   E_NOINTERFACE = $80004002;
  9272. begin
  9273.   if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
  9274. end;
  9275.  
  9276. function TInterfacedObject._AddRef: Integer;
  9277. begin
  9278.   Inc(FRefCount);
  9279.   Result := FRefCount;
  9280. end;
  9281.  
  9282. function TInterfacedObject._Release: Integer;
  9283. begin
  9284.   Dec(FRefCount);
  9285.   if FRefCount = 0 then
  9286.   begin
  9287.     Destroy;
  9288.     Result := 0;
  9289.     Exit;
  9290.   end;
  9291.   Result := FRefCount;
  9292. end;
  9293.  
  9294. procedure _CheckAutoResult;
  9295. asm
  9296.         TEST    EAX,EAX
  9297.         JNS     @@2
  9298.         MOV     ECX,SafeCallErrorProc
  9299.         TEST    ECX,ECX
  9300.         JE      @@1
  9301.         MOV     EDX,[ESP]
  9302.         CALL    ECX
  9303. @@1:    MOV     AL,reSafeCallError
  9304.         JMP     Error
  9305. @@2:
  9306. end;
  9307.  
  9308.  
  9309. procedure _IntfDispCall;
  9310. asm
  9311.         JMP     DispCallByIDProc
  9312. end;
  9313.  
  9314.  
  9315. procedure _IntfVarCall;
  9316. asm
  9317. end;
  9318.  
  9319. initialization
  9320.  
  9321.   ExitCode  := 0;
  9322.   ErrorAddr := nil;
  9323.  
  9324.   RandSeed := 0;
  9325.   FileMode := 2;
  9326.  
  9327.   Test8086 := 2;
  9328.   Test8087 := 3;
  9329.  
  9330.   TVarData(Unassigned).VType := varEmpty;
  9331.   TVarData(Null).VType := varNull;
  9332.  
  9333.   _FpuInit();
  9334.  
  9335.   _Assign( Input, '' );  { _ResetText( Input );   }
  9336.   _Assign( Output, '' );  { _RewritText( Output ); }
  9337.  
  9338.   CmdLine := GetCommandLine;
  9339.   CmdShow := GetCmdShow;
  9340.  
  9341. finalization
  9342.   Close(Input);
  9343.   Close(Output);
  9344.   UninitAllocator;
  9345. end.
  9346.